[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ユーザーフォームについて』（れいまま）
こんばんは。 またまた教えてください<(＿＿*)＞（また れいままだよ～って思った方ごめんなさい） 今、ユーザーフォームについて勉強しています。 下記のような入力フォームのｺｰﾄﾞを作ってみました。 （Sheet1） A B C D E F G H I J K L M N O P 番号 伝票番号 お客様のお名前 月 日 ☆ 時間 店所ｺｰﾄﾞ 担当店 電話番号 携帯番号 郵便番号 住所① 住所② 事前連絡 備考
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1.Text = FR.EntireRow.Cells(1, "A").Text
Me.Tag = FR.Row
Set FR = Nothing
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("B2").Value = TextBox2.Text
TextBox2.Text = Format(WorksheetFunction.Substitute(TextBox1.Text, "-", ""), "0000-0000-0000")
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("C2").Value = TextBox3.Text
End Sub
Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("D2").Value = TextBox4.Text
End Sub
Private Sub TextBox5_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("E2").Value = TextBox5.Text
End Sub
Private Sub TextBox6_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim FR As Range
With Sheets("時間帯")
Set FR = .Range("A:A").Find(TextBox6.Text, , xlValues, xlWhole)
If Not FR Is Nothing Then
TextBox7.Text = FR.EntireRow.Cells(1, "B").Text
Set FR = Nothing
End If
Range("G2").Value = TextBox7.Text
End With
End Sub
Private Sub TextBox8_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim FR As Range
With Sheets("店所")
Set FR = .Range("A:A").Find(TextBox8.Text, , xlValues, xlWhole)
If Not FR Is Nothing Then
TextBox9.Text = FR.EntireRow.Cells(1, "D").Text
Set FR = Nothing
End If
Range("H2").Value = TextBox8.Text
Range("I2").Value = TextBox9.Text
End With
End Sub
Private Sub TextBox10_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("J2").Value = TextBox10.Text
End Sub
Private Sub TextBox11_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("K2").Value = TextBox11.Text
End Sub
Private Sub TextBox12_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim FR As Range
With Sheets("郵便番号")
Set FR = .Range("A:A").Find(TextBox12.Text, , xlValues, xlWhole)
If Not FR Is Nothing Then
TextBox13.Text = FR.EntireRow.Cells(1, "B").Text
Set FR = Nothing
End If
Range("M2").Value = TextBox13.Text
End With
End Sub
Private Sub TextBox14_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("N2").Value = TextBox14.Text
End Sub
Private Sub TextBox15_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim FR As Range
With Sheets("事前連絡")
Set FR = .Range("A:A").Find(TextBox15.Text, , xlValues, xlWhole)
If Not FR Is Nothing Then
TextBox16.Text = FR.EntireRow.Cells(1, "B").Text
Set FR = Nothing
End If
Range("O2").Value = TextBox16.Text
End With
End Sub
Private Sub TextBox17_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Range("P2").Value = TextBox17.Text
End Sub
Private Sub UserForm_Initialize()
TextBox1.TabStop = False '見せるだけで入力しないときはFalseらしい
TextBox13.TabStop = False
End Sub
BOX17を入力したらPに表示した後 次の行へ入力させたいのですが どうしたらいいのでしょうか？ それと CommandButtonで戻るという設定をしたいと思います。 一行戻るのは どういう設定にしたらいいのでしょうか？
お風呂に入ったら閃きました（笑 次の行に入力というのは 常に最終行を取得して その下に書き込みをするようにすればいい！ ということですね。 途中まで入力したものは 表示させないようにすれば ずれることはない！ おおお～♪
しかし、一つ前に戻るというのは よく分からないです。どなたか 教えてください。 （れいまま）
行を変数で制御してはどうでしょうか？ 次の行に行くには＋１して、前に戻るのは－１すればできますよ。
1行単位で移動するものだと思って回答しています。 （やっちん）
やっちんさん＞おはようございます。 そうなのです。１行単位です。 +1 -1ですね。 なるほど。思いつかなかったです。 これが完成すれば 色々な入力作業に応用できます。 画面が どんなに横に長くても画面を移動しなくてすみますから。 入力作業の時間短縮になります。 ありがとうございました（嬉 （れいまま）
戻すのは確認の為に表示するだけですか？それとも一部を入力し直す為ですか？ 戻るのが1つ前までの限定であれば問題ないと思いますが、複数行も戻る場合は新規 に入力するときに最終行を取得するか最終行を保持しておく必要があるでしょうね。 そうしないと入力済みの行を上書きしていってしまいます。 （やっちん）
やっちんさん＞こんにちは。 確認が主ですが、確認作業で間違いがあったら訂正したいですね。 新しくコマンドﾎﾞﾀﾝを作って修正できるようにした方がいいかもしれないですね。 ありがとうございます。 （れいまま）
えーーと、 最下行のセル、アドレス、または行などを一度変数に格納してやれば、 どこに移動しようと、戻れますよね？ (seiya)
えと、このスレに関係無い事ですけど、ごめんなはれや。 一応出来上がりましたんで、検証頼んます。（例の所） バイオレットで塗ってあるセルは完全一致が不可能なデータデスワ。 それと正規のデータは横のセルに逃がしてあります。本データは曖昧な数値になっとり ますもんで、違いがハッキリしたデータで検証すべきと思いましてナ。 ただまぁ、元に戻す際は今一度再確認お願いします。 住所を入力したら半角に変換にするのをお忘れ無く。 住所が全く同じやと、空白行で表示されます。 （弥太郎）
seiyaさん＞こんばんは。o(^-^ o ) 全て変数に格納することで 何番目を参照しても新しい行に 移動できるということですよね。 れいまま 変数を自分のものにする良いチャンスだと思っています。 だから 頑張りますｗ
ちなみに ユーザーフォームの内容は
No【BOX1】 伝票番号をハイフォンなしで入力してください 【BOX2】 お客さまの名前を入れてください 【BOX3】 日にち 時間を選んでください 【BOX4】月【BOX5】日 【BOX6】【BOX７】 １ AM ２ PM ３ FREE 担当店を入力してください 電話番号 【BOX８】 【BOX10】 【BOX9】店 【BOX11】 郵便番号を入れてください 【BOX12】 住所を入れてください 事前連絡 【BOX13】（郵便番号を入れると表示されます） 【BOX15】【BOX16】 【BOX14】（番地など手入力します） １ ○ 2 × 備考 【BOX17】 です。 出来上がったらアップするので見てくださいね。 今、【BOX1】にNOをふる関数を本で調べているところです。 変数 早速試しま～す
弥太郎さん♥o(^-^ o ) ありがとうございます。早速見てみます☆ とっても嬉しいです♪ヾ(●⌒∇⌒●)ﾉ わーい 実物で検証するのは年明けになってしまうかもしれません。 会社のPCの前でゆっくりマクロいじる時間がとれないのです（涙 弥太郎さんのマクロがうまくいったら 上のユーザーフォームの担当店で活躍しそうです （れいまま）
弥太郎さん！！ これすごい！れいまま 早く試したくなったです！ 年内に裏技を使って試します（笑 紫のところは そうそう注文ないでしょう。 だからOkだと思います。 本当にありがとうございます！ 来年の繁忙期は これでばっちりです！ （れいまま）
>来年の繁忙期は これでばっちりです！
世の中そう上手い事でけておりまへんわ。（笑
さっそく不具合を発見（藤沢○丁目で）しましたんで、下のコードと差し替えておくん
なはれ。
それと先方とのやりとり上全角がベターやと思いますんで、変数上だけで半角に変換検
索するよう書き換えときました。5,600のデータやと.0x秒程遅くなるだけですから問題
おまへんやろ？
（弥太郎）
'----------------
Sub ReimamaVer4()
Dim dic As Object, i As Long, n As Integer, Rex As Object, tbl, x, ky
Dim flag As Boolean, d_1 As String, d_2 As String, chck_data As Long
Dim maxrow As Long, maxcol As Integer, fnd_data As String
Dim a_1 As String, a_2 As String, a_3 As Long, c_data As String
Dim md_1 As Integer, md_2 As Integer, myflg As Boolean, myflg_1 As Boolean
Dim myflg_2 As Boolean
Set dic = CreateObject("scripting.dictionary")
Set Rex = CreateObject("vbscript.regexp")
With Sheets("作業")
tbl = .Range("h2").Resize(.Range("h" & Rows.Count).End(xlUp).Row - 1)
ReDim x(1 To UBound(tbl, 1), 1 To 1)
With CreateObject("vbscript.regexp")
On Error Resume Next
For i = 1 To UBound(tbl, 1)
fnd_data = StrConv(tbl(i, 1), vbNarrow)
Rex.Pattern = "^(神奈川県)*(.+市|中郡|足柄上郡|.+郡.+町)(.+)"
a_1 = Rex.Replace(fnd_data, "$2")
a_2 = Rex.Replace(fnd_data, "$3")
Rex.Pattern = "\d+"
If Rex.test(a_2) Then
a_3 = Rex.Execute(a_2)(0)
Else
a_3 = 0
End If
dic(a_1 & "," & a_2) = Array(a_3, i)
On Error GoTo 0
Next i
End With
End With
With Sheets("担当店一覧")
maxrow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
maxcol = .Cells.Find("番号", , , , xlByColumns, xlPrevious).Column
tbl = .Range("a1").Resize(maxrow, maxcol).Value
For Each ky In dic.keys
d_1 = Split(ky, ",")(0)
d_2 = Split(ky, ",")(1)
c_data = d_2
myflg = c_flg(d_1, d_2)
myflg_1 = d_flg(d_1, d_2)
myflg_2 = IIf(myflg Or myflg_1, False, True)
If myflg_2 Then
Rex.Pattern = "\D+"
c_data = Rex.Execute(c_data)(0)
ElseIf myflg Then
Rex.Pattern = ".+丁目"
If Rex.test(c_data) Then
c_data = Rex.Execute(c_data)(0)
Else
Rex.Pattern = "\D+\d+"
c_data = Rex.Execute(c_data)(0)
End If
End If
For n = 1 To UBound(tbl, 2) Step 3
If d_1 = tbl(1, n) Then
For i = 3 To .Cells(Rows.Count, n).End(xlUp).Row
If myflg_2 Or myflg Then
If c_data = tbl(i, n) Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
ElseIf tbl(i, n) Like "*~*" Then
chck_data = dic(d_1 & "," & d_2)(0)
If Right(tbl(i, n), 1) = "~" Then
Rex.Pattern = "^(\D+|.+丁目)(\d+)~$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = 10000
Else
Rex.Pattern = "^(\D+|.+丁目)(\d+)~(\d+)$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = Rex.Replace(tbl(i, n), "$3")
End If
If chck_data >= md_1 And chck_data <= md_2 Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
End If
If Right(tbl(i, n), 1) = "他" And c_data Like "*" & Left(tbl(i, n), _
Len(tbl(i, n)) - 1) & "*" Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
If flag Then Exit For
Next i
If flag Then
md_1 = 0: md_2 = 0: chck_data = 0
flag = False
Exit For
End If
End If
Next n
Next ky
End With
With Sheets("作業")
.Cells(2, 4).Resize(UBound(x)) = x
End With
Set dic = Nothing
Set Rex = Nothing
End Sub
Private Function c_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean
c_flg = False
With CreateObject("vbscript.regexp")
.Pattern = "^(厚木|綾瀬|海老名)市(旭町|中町|落合南|小園|深谷1100|中央)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(小田原|相模原|茅ヶ崎)市(栄町\d|上鶴間\d|相模大野|東林間|淵野辺|橋本\d|東海岸北|みづき\d)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(秦野|藤沢|大和)市(下鶴間4811|中央\d|曽屋\d+丁目|藤沢\d+丁目|福田\d+丁目|福田4417)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(足柄下郡箱根)町(木賀|二の平|元箱根)\d"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
End With
End Function
Private Function d_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean
d_flg = False
With CreateObject("vbscript.regexp")
.Pattern = "^(厚木|綾瀬|伊勢原|秦野|藤沢|平塚|大和)市(泉町|深谷|三宮|曽屋|藤沢|中原下宿|福田|馬入|下鶴間)\d"
If .test(d_1 & d_2) Then
d_flg = True
.Pattern = ".+丁目"
If .test(d_1 & d_2) Then
d_flg = False
End If
Exit Function
End If
.Pattern = "^(愛甲郡愛川|足柄下郡箱根)町(中津|二の平)\d"
If .test(d_1 & d_2) Then
d_flg = True
Exit Function
End If
End With
End Function
弥太郎さん♪ メリークリスマス☆ ありがとうございます。 とっても嬉しい クリスマスプレゼントになりました。 早速ｺｰﾄﾞ入れ替えます。 今日は気持ち悪くて早退してしまったので まだ 試していないのです。明日 試してみますね。 薬もらったので 明日は大丈夫だと思います。 （れいまま）
>今日は気持ち悪くて早退してしまったので それは、それは・・・お大事に。 どっかの陰から弥太郎の顔を覗いた所為で・・とかやおまへんわなぁ・・・（笑 （弥太郎）
弥太郎さん 試してみました。 遅くなってすみません。 ＞それと先方とのやりとり上全角がベターやと思いますんで、変数上だけで半角に変換検 索するよう書き換えときました
と言うことは、半画に変換しなくても良いということですよね。 そのままVer４を試してみました。 結果ですが・・・ ほぼ 表示されました。が・・・ [壁]_･)ﾁﾗｯ なんとも もうしあげにくいのですがｍ(｡≧Д≦｡)ｍ 作業シートを半画に変換してVer1で試したほうが より多くの店所を表示しました。 弥太郎さんが 時間をかけてくださったのに・・・ o(；△；)o 半画へ変換してからもVer４を試しましたが 結果は同じでした。
どちらにも共通して店所を表示しなかったのが ○ヶ○という住所で ○ケ○と添付されてくるものです。 こればっかりは 半画変換しても表示されませんでした。 Ver１では この文字の場所１箇所だけで後はパーフェクトでした。 Ver４は13個表示されませんでした。 な～ぜ～？？？ 手の込んだほうが表示されないの？？？といった心境です。 全部パーフェクトでしたと嘘の報告でもと思ったのですが 悩んだけど 本当のこと書きました。 "(/へ＼*) 弥太郎さん ありがとうございます。 感謝の気持ちでいっぱいです。（真実） （２１時まで会社で仕事していた れいまま）
＞それは、それは・・・お大事に。 ありがとうございます。今日は元気に仕事しましたｗ ＞どっかの陰から弥太郎の顔を覗いた所為で・・とかやおまへんわなぁ・・・（笑 弥太郎さんにお会いしたら元気もりもりですｗ 23：20追加
気になったところをもう1つ ｺｰﾄﾞ表示すると Private Function c_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean の場所の上に線が引かれています。 もしかして 作動していないのかも・・・？ （れいまま）
>全部パーフェクトでしたと嘘の報告 は、止めておくんなはれ。乗りかかった船ですから、この件に関してはヤケクソにな ってでも仕上げますワ。（笑 一応下のコードでヶケは解消する（多分）と思うんですが、担当店一覧の松が丘とか ひばりが丘、星が丘とかは星ヶ丘などと先方から送りつけてきますんやろか？ それやと、それに対応するよう加えなあきまへんもんで・・・
も一つ旭町１丁目３－４ は検索上旭町１丁目としとりますけど、旭町１－３－４等 丁目省略方で送付してくるばやいはありまへんか？ （弥太郎）
Sub ReimamaVer4()
Dim dic As Object, i As Long, n As Integer, Rex As Object, tbl, x, ky
Dim flag As Boolean, d_1 As String, d_2 As String, chck_data As Long
Dim maxrow As Long, maxcol As Integer, fnd_data As String
Dim a_1 As String, a_2 As String, a_3 As Long, c_data As String
Dim md_1 As Integer, md_2 As Integer, myflg As Boolean, myflg_1 As Boolean
Dim myflg_2 As Boolean
Set dic = CreateObject("scripting.dictionary")
Set Rex = CreateObject("vbscript.regexp")
With Sheets("作業")
tbl = .Range("h2").Resize(.Range("h" & Rows.Count).End(xlUp).Row - 1)
ReDim x(1 To UBound(tbl, 1), 1 To 1)
With CreateObject("vbscript.regexp")
On Error Resume Next
For i = 1 To UBound(tbl, 1)
fnd_data = StrConv(tbl(i, 1), vbNarrow)
.Pattern = ".+(ｹ).+"
If .test(fnd_data) Then
fnd_data = Replace(fnd_data, .Replace(fnd_data, "$1"), "ヶ")
End If
Rex.Pattern = "^(神奈川県)*(.+市|中郡|足柄上郡|.+郡.+町)(.+)"
a_1 = Rex.Replace(fnd_data, "$2")
a_2 = Rex.Replace(fnd_data, "$3")
Rex.Pattern = "\d+"
If Rex.test(a_2) Then
a_3 = Rex.Execute(a_2)(0)
Else
a_3 = 0
End If
dic(a_1 & "," & a_2) = Array(a_3, i)
On Error GoTo 0
Next i
End With
End With
With Sheets("担当店一覧")
maxrow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
maxcol = .Cells.Find("番号", , , , xlByColumns, xlPrevious).Column
tbl = .Range("a1").Resize(maxrow, maxcol).Value
For Each ky In dic.keys
d_1 = Split(ky, ",")(0)
d_2 = Split(ky, ",")(1)
c_data = d_2
myflg = c_flg(d_1, d_2)
myflg_1 = d_flg(d_1, d_2)
myflg_2 = IIf(myflg Or myflg_1, False, True)
If myflg_2 Then
Rex.Pattern = "\D+"
c_data = Rex.Execute(c_data)(0)
ElseIf myflg Then
Rex.Pattern = ".+丁目"
If Rex.test(c_data) Then
c_data = Rex.Execute(c_data)(0)
Else
Rex.Pattern = "\D+\d+"
c_data = Rex.Execute(c_data)(0)
End If
End If
For n = 1 To UBound(tbl, 2) Step 3
If d_1 = tbl(1, n) Then
For i = 3 To .Cells(Rows.Count, n).End(xlUp).Row
If myflg_2 Or myflg Then
Rex.Pattern = ".+(ｹ).+"
If Rex.test(tbl(i, n)) Then
tbl(i, n) = Replace(tbl(i, n), Rex.Replace(tbl(i, n), "$1"), "ヶ")
End If
If c_data = tbl(i, n) Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
ElseIf tbl(i, n) Like "*~*" Then
chck_data = dic(d_1 & "," & d_2)(0)
If Right(tbl(i, n), 1) = "~" Then
Rex.Pattern = "^(\D+|.+丁目)(\d+)~$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = 10000
Else
Rex.Pattern = "^(\D+|.+丁目)(\d+)~(\d+)$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = Rex.Replace(tbl(i, n), "$3")
End If
If chck_data >= md_1 And chck_data <= md_2 Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
End If
If Right(tbl(i, n), 1) = "他" And c_data Like "*" & Left(tbl(i, n), _
Len(tbl(i, n)) - 1) & "*" Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
If flag Then Exit For
Next i
If flag Then
md_1 = 0: md_2 = 0: chck_data = 0
flag = False
Exit For
End If
End If
Next n
Next ky
End With
With Sheets("作業")
.Cells(2, 4).Resize(UBound(x)) = x
End With
Set dic = Nothing
Set Rex = Nothing
End Sub
弥太郎さん＞｡･ﾟ((T◇Tﾟ)ﾟ･｡ｵﾛｵﾛ｡･ﾟ(ﾟT◇T))ﾟ･｡ ありがとうございます。
＞も一つ旭町１丁目３－４ は検索上旭町１丁目としとりますけど、旭町１－３－４等 ＞丁目省略方で送付してくるばやいはありまへんか？ ↑ありでございます。┏（＿□＿：）┓
送られてくる住所はお客様が書いたものを担当者が入力したと 思われます。 それを そのまま送ってくるのです。担当者は一人ではないと思うので 入力方法が統一されていないのだと・・・ しかも お客様によっては ○番地○と申告する方もいれば ○ｰ○と申告される方もいます。 なので難しいのだと思います。 (誰も 住所からマクロでお店を表示させようとしているなんて 思いもしないと思うので 住所が分かればいいくらいの記載なのです 実際 出来る人なんて れいままの会社にはシステム開発以外ほとんどいないと思われます） 早速試してみます 弥太郎さん ありがとうございます。 （れいまま）
弥太郎さん 報告です。
試してみました。
表示されない住所は
海-東梶ヶ谷
厚-上荻野
相-津久井町
藤-善行
足-松田町
大-中央
平-代官町
相-弥栄
藤-片瀬
相-田名
足-中井町
でした。
ちなみに
Ver１は表示されました。
Sub reimamahanVer1()
Dim dic As Object, i As Long, x, n As Integer, tbl, ky
Set dic = CreateObject("scripting.dictionary")
With Sheets("担当店一覧")
maxrow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
maxcol = .Cells.Find("番号", , , , xlByColumns, xlPrevious).Column
tbl = .Range("a1").Resize(maxrow, maxcol).Value
For n = 1 To UBound(tbl, 2) Step 3
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, n)) Then
dic(StrConv(tbl(1, n), vbNarrow) & StrConv(tbl(i, n), _
vbNarrow)) = tbl(i, n + 1)
End If
Next i
Next n
End With
Erase tbl
With Sheets("作業")
tbl = .Range("ｈ2").Resize(.Range("ｈ" & Rows.Count).End(xlUp).Row)
ReDim x(1 To UBound(tbl, 1), 1 To 1)
For Each ky In dic.keys
For i = 1 To UBound(tbl, 1)
data = StrConv(tbl(i, 1), vbNarrow)
If data Like "*" & ky & "*" Then
x(i, 1) = dic.Item(ky)
End If
Next i
Next ky
.Cells(2, 4).Resize(UBound(tbl, 1)) = x
End With
Set dic = Nothing
End Sub （れいまま）
どっかマクロ触りましたぁ？
当方では全て正常に拾い出しとりますがなぁ？？
念のためこんなデータ（全角）も正確に拾いまっせ。
神奈川県海老名市東梶ヶ谷５－３
神奈川県海老名市東梶ケ谷４－３
も一遍コピペしてくらはい。ヶ、ケ、は対処しとりますが 「が」とケ、ヶと同等に
扱うのには対処しとりまへん。
（弥太郎）
'---------------------
Sub ReimamaVer5()
Dim dic As Object, i As Long, n As Integer, Rex As Object, tbl, x, ky
Dim flag As Boolean, d_1 As String, d_2 As String, chck_data As Long
Dim maxrow As Long, maxcol As Integer, fnd_data As String
Dim a_1 As String, a_2 As String, a_3 As Long, c_data As String
Dim md_1 As Integer, md_2 As Integer, myflg As Boolean, myflg_1 As Boolean
Dim myflg_2 As Boolean
Set dic = CreateObject("scripting.dictionary")
Set Rex = CreateObject("vbscript.regexp")
With Sheets("作業")
tbl = .Range("h2").Resize(.Range("h" & Rows.Count).End(xlUp).Row - 1)
ReDim x(1 To UBound(tbl, 1), 1 To 1)
With CreateObject("vbscript.regexp")
On Error Resume Next
For i = 1 To UBound(tbl, 1)
fnd_data = StrConv(tbl(i, 1), vbNarrow)
.Pattern = ".+(ｹ).+"
If .test(fnd_data) Then
fnd_data = Replace(fnd_data, .Replace(fnd_data, "$1"), "ヶ")
End If
Rex.Pattern = "^(神奈川県)*(.+市|中郡|足柄上郡|.+郡.+町)(.+)"
a_1 = Rex.Replace(fnd_data, "$2")
a_2 = Rex.Replace(fnd_data, "$3")
Rex.Pattern = "\d+"
If Rex.test(a_2) Then
a_3 = Rex.Execute(a_2)(0)
Else
a_3 = 0
End If
dic(a_1 & "," & a_2) = Array(a_3, i)
On Error GoTo 0
Next i
End With
End With
With Sheets("担当店一覧")
maxrow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
maxcol = .Cells.Find("番号", , , , xlByColumns, xlPrevious).Column
tbl = .Range("a1").Resize(maxrow, maxcol).Value
For Each ky In dic.keys
d_1 = Split(ky, ",")(0)
d_2 = Split(ky, ",")(1)
c_data = d_2
myflg = c_flg(d_1, d_2)
myflg_1 = d_flg(d_1, d_2)
myflg_2 = IIf(myflg Or myflg_1, False, True)
If myflg_2 Then
Rex.Pattern = "(\W+町)(.+)*"
If Rex.test(c_data) Then
c_data = Rex.Replace(c_data, "$1")
Else
Rex.Pattern = "\W+"
c_data = Rex.Execute(c_data)(0)
End If
ElseIf myflg Then
Rex.Pattern = ".+丁目"
If Rex.test(c_data) Then
c_data = Rex.Execute(c_data)(0)
Else
Rex.Pattern = "\D+\d+"
c_data = Rex.Execute(c_data)(0)
End If
End If
For n = 1 To UBound(tbl, 2) Step 3
If d_1 = tbl(1, n) Then
For i = 3 To .Cells(Rows.Count, n).End(xlUp).Row
If myflg_2 Or myflg Then
Rex.Pattern = ".+(ｹ).+"
If Rex.test(tbl(i, n)) Then
tbl(i, n) = Replace(tbl(i, n), Rex.Replace(tbl(i, n), "$1"), "ヶ")
End If
If c_data = tbl(i, n) Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
ElseIf tbl(i, n) Like "*~*" Then
chck_data = dic(d_1 & "," & d_2)(0)
If Right(tbl(i, n), 1) = "~" Then
Rex.Pattern = "^(\D+|.+丁目)(\d+)~$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = 10000
Else
Rex.Pattern = "^(\D+|.+丁目)(\d+)~(\d+)$"
md_1 = Rex.Replace(tbl(i, n), "$2")
md_2 = Rex.Replace(tbl(i, n), "$3")
End If
If chck_data >= md_1 And chck_data <= md_2 Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
End If
If Right(tbl(i, n), 1) = "他" And c_data Like "*" & Left(tbl(i, n), _
Len(tbl(i, n)) - 1) & "*" Then
x(dic(d_1 & "," & d_2)(1), 1) = tbl(i, n + 1)
flag = True
End If
If flag Then Exit For
Next i
If flag Then
md_1 = 0: md_2 = 0: chck_data = 0
flag = False
Exit For
End If
End If
Next n
Next ky
End With
dic.removeall
With Sheets("作業")
.Cells(2, 4).Resize(UBound(x)) = x
tbl = .Cells(2, 4).Resize(UBound(x), 5)
For i = 1 To UBound(tbl, 1)
If IsEmpty(tbl(i, 1)) And Not dic.exists(tbl(i, 5)) Then
dic(tbl(i, 5)) = i
ElseIf dic.exists(tbl(i, 5)) Then
.Cells(dic.Item(tbl(i, 5)) + 1, 4) = tbl(i, 1)
dic.Remove (tbl(i, 5))
End If
Next i
End With
Set dic = Nothing
Set Rex = Nothing
End Sub
'---------------------------------
↑とは別のもんですよ。
Private Function c_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean
c_flg = False
With CreateObject("vbscript.regexp")
.Pattern = "^(厚木|綾瀬|海老名)市(旭町|中町|落合南|小園|深谷1100|中央)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(小田原|相模原|茅ヶ崎)市(栄町\d|上鶴間\d|相模大野|東林間|淵野辺|橋本\d|東海岸北|みづき\d)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(秦野|藤沢|大和)市(下鶴間4811|中央\d|曽屋\d+丁目|藤沢\d+丁目|福田\d+丁目|福田4417)"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
.Pattern = "^(足柄下郡箱根)町(木賀|二の平|元箱根)\d"
If .test(d_1 & d_2) Then
c_flg = True
Exit Function
End If
End With
End Function
'------------------------------------
'↑とは別のもんですよ。
Private Function d_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean
d_flg = False
With CreateObject("vbscript.regexp")
.Pattern = "^(厚木|綾瀬|伊勢原|秦野|藤沢|平塚|大和)市(泉町|深谷|三宮|曽屋|藤沢|中原下宿|福田|馬入|下鶴間)\d"
If .test(d_1 & d_2) Then
d_flg = True
.Pattern = ".+丁目"
If .test(d_1 & d_2) Then
d_flg = False
End If
Exit Function
End If
.Pattern = "^(愛甲郡愛川|足柄下郡箱根)町(中津|二の平)\d"
If .test(d_1 & d_2) Then
d_flg = True
Exit Function
End If
End With
End Function
マクロいじらないですけど・・・
質問です。 別のものはどうやって作動したらいいのでしょうか？ (れいまま）
作動はしまへん。 必要な時に本マクロから覗きに参上して必要なデータを持ち帰ります。 c_flgは丁目で検索する資料になっとります（結果はTrueとFalseで） d_flgは～の有る無しを判断します。要するにこのマクロにひっついた関数みたいな もんですわ。 例えば厚 - 旭町３丁目はc_flgはTrueで、c_flgはFalseを、泉町はc_flg=False,d_flg =Trueを、また東梶ヶ谷は両方に属しまへんからc_flgもd_flgもFalseで処理されるん ですワ。 （弥太郎）
う～ん・・・ やはり表示されないないのです。 なぜ？？？ 海-東柏ケ谷 も表示されないです・・・ （れいまま）
ほならあそこへUPしときますワ。あれで試してみてくらはい。 （弥太郎）
ありがとうございます。 同じのUPしましたので 弥太郎さんお試しください。 （れいまま）
224 神奈川県海老名市東柏ケ谷６丁目１３－ 224 神奈川県海老名市東柏ケ谷３丁目４－ 019 神奈川県厚木市上荻野４２６０ 神奈川県相模原市津久井町長竹１７８５－１ 神奈川県藤沢市善行１－ 035 神奈川県藤沢市善行１－ 神奈川県足柄上郡松田町神山２５－ 神奈川県大和市中央６丁目８－ 520 神奈川県大和市中央６丁目８－ 140 神奈川県平塚市代官町３５－ 608 神奈川県相模原市弥栄２丁目１６－ 011 神奈川県藤沢市片瀬５丁目２－ 564 神奈川県相模原市田名５５８１ 神奈川県足柄上郡中井町井ノ口１５７４ー 結果は以上ですワ。 津久井町長竹は津久井町の後数値で検索しとりますから（中井町、松田町も同じ）一致 しまへん。 善行は同一住所ですから一つしか拾いまへん。同一住所に２回に分けて発送するのは 非現実的ですわなぁ。２個口とか３個口で事足りますからなぁ。 善行１－２ 善行１－３と入力して試すとお分かりになろうかと おもわれます。中央６丁目８も同じ事が言えます。 ところで、実際に松田町神山とか中井町井ノ口とかが（町の後が数値でない）拾えない のは考えてみますワ。 （弥太郎）
そうそう、その同一住所が頻繁にあるんなら空のセルを検索してそこを埋めるマクロを 追加してもよろしいで。 （弥太郎）
弥太郎さん＞ありがとうございます。 一回に発送なのですが 同じ名前・住所で伝票番号違いが沢山あるのです。 Ver1で拾ってくれるのとは なにが違うのでしょうか？ （れいまま） 衝突してしまいましたｗ 頻繁にあります。 ぜひ お願いします。
広告の住所とかひろって 架空のでまた 試してみます。 実物データーは会社から持ち出せないので・・・ ↑ 適当にいれた住所ですが 実際の方いらしたらごめんなさいね。
もう一回ようくみたら 表示されないのは重複しているやつですね。 ↑ 説明納得しました。 (れいまま）
↑にVer5として中井町井ノ口云々を対処、同住所も拾うよう変更しときました。 また、アラ捜してくらはい。 Ver1との違いは検索方法を逆にして空振りをなくしたんですワ。あれ、～とか 他とか に対応しとりまへんで、あくまで曖昧検索ですから１００％はとても無理です。 えらいコードが長くなってしまいましたなぁ（笑 完全主義者はつらい・・・（弥太郎）
弥太郎さん♥ ありがとうございます。 弥太郎さんを独占した気分で とってもいい気持ちです（笑 これから 日々作業をするなかで 何か不具合が生じたら ぜひ お願いします。 れいままにはレベル高すぎて このマクロ理解できないです・・・（汗 今からケーキを買いに行きます。 クリスマスは具合悪くて食べれなかったのでｗ 夕飯食べてから試します。 ありがとうございます。 （れいまま） そうそう、 明日朝礼当番が回ってくることになりました。 あの日が昇る～の話させていただきますｗ
>弥太郎さんを独占した気分で とってもいい気持ちです（笑
そ・そんな～
σ(^o^;)の、ししょ～ですねんでぇｗ
試しに作ってみました。
が、時間がかかるようです。。。
まぁ、勉強って事でｗｗｗ
Sub test()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim MyAd As String, AdKey As String
Dim i As Long, n As Long, c As Long
Dim ad_1 As Integer, ad_2 As Integer
On Error Resume Next
With Worksheets("担当店一覧")
Set MyDic = CreateObject("Scripting.Dictionary")
For n = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column Step 3
MyA = .Range(.Cells(1, n), .Cells(.Cells(.Rows.Count, n).End(xlUp).Row, n + 2))
For i = 3 To UBound(MyA, 1)
MyAd = StrConv(MyA(i, 1), vbNarrow)
With CreateObject("VBScript.RegEXP")
.Pattern = "^(.+)(\d+)~(\d+)$"
If .test(MyAd) Then
ad_1 = .Replace(MyAd, "$2")
ad_2 = .Replace(MyAd, "$3")
For c = ad_1 To ad_2
MyDic(MyA(1, 1) & .Replace(MyAd, "$1") & c) = MyA(i, 2)
Next c
Else
MyDic(MyA(1, 1) & MyA(i, 1)) = MyA(i, 2)
End If
End With
Next i
Next n
End With
ReDim MyAry(1 To MyDic.Count, 1 To 2)
With Worksheets("作業")
MyA = .Range("H2", .Range("H" & Rows.Count).End(xlUp))
ReDim MyAry(1 To UBound(MyA, 1), 1 To 1)
For i = 1 To UBound(MyA, 1)
With CreateObject("VBScript.RegEXP")
AdKey = StrConv(MyA(i, 1), vbNarrow)
.Pattern = ".+(ｹ).+"
If .test(StrConv(MyA(i, 1), vbNarrow)) Then
AdKey = Replace(AdKey, "ｹ", "ヶ")
End If
If MyA(i, 1) Like "*丁目*" Then
.Pattern = "^(神奈川県){0,1}(.+丁目).*$"
AdKey = .Replace(AdKey, "$2")
Else
.Pattern = "^(神奈川県){0,1}(\D+)\d*(-\d){0,1}$"
AdKey = .Replace(AdKey, "$2")
End If
If Not MyDic.Exists(AdKey) Then
.Pattern = "^(神奈川県){0,1}(\D+)\d+.*$"
AdKey = .Replace(AdKey, "$2")
End If
Do While Not MyDic.Exists(AdKey)
AdKey = Mid$(AdKey, 1, Len(AdKey) - 1)
Loop
End With
MyAry(i, 1) = MyDic.Item(AdKey)
Next i
.Range("D2").Resize(UBound(MyAry, 1)) = MyAry()
End With
Set MyDic = Nothing
Erase MyA, MyAry
End Sub
（キリキ）（〃⌒o⌒)b
まっ、せんせぇったらイヤですわ～、パタンなんておめかししちゃって、ゴホンゴホン あ、いや、酔うてまへんでぇ、酔うてまへん、ハイ、ふ～っ・・・。 ところでれいままさん、明日は待望の朝礼当番みたいでんなぁ。 突っ込まれないよう予備知識として http://search.yahoo.co.jp/search?p=%C6%FC%A4%CF%CB%F4%BE%BA%A4%EB&fr=top_v2&tid=top_v2&ei=euc-jp&search.x=1 を拾い読みしときまひょ。（笑 （弥太郎）
キリキさんｗ＞こんばんは～ 嬉しいです。れいまま作れないです・・・（尊敬） 時間はかかってもかまいません。 気持ちがとっても嬉しいです。 自分が質問したことに対して 一生懸命やってくださった全ての方に ありがとうの気持ちが必要なのだと思います。 ご飯食べてから試してみますね。 今日は買い物に行ってお財布忘れて・・・ ご飯が遅くなってしまいました
弥太郎さん＞ 本のことをおっしゃりたいのかしら？ 日はまた昇るって本ありましたよね？たしか・・・
話かわって Ver５の件ですが 同じのが空白だったような・・・ ご飯の支度しながら試したので（汗 あとでゆっくり見てみます。
れいままも いつか弟子入りさせてください（笑 そしたら とりっこにならい？（笑 （れいまま）
ｷﾘｷさんｗ 実物で試してみましたｗ 近隣の営業所で試しました。 コメントが出てきました。 やはりエラーが出ましたかって。 おちゃめなコメントだと思います。 （れいまま） 弥太郎さん＞ Ver５確認しました。 藤-善行の重複分と 相-田名の重複分以外 全て表示されています。
ちこっと上記コード修正しました。 時間があるときに試してもらって、何が駄目か教えて～ （キリキ）(〃⌒o⌒)b
完成間近バージョンＵＰしますた。 お試しあれ。 （弥太郎）
キリキさん＞ありがとうございます。 了解しました。
弥太郎さん＞ 楽しみにしています。 早速朝礼でつっこまれました（笑 一番えらい人に二度もｗ （れいまま）
弥太郎さん＞ ｡･:*:･ﾟ★,｡･:*:･ﾟ☆ very d(*⌒▽⌒*)b good ｡･:*:･ﾟ★,｡･:*:･ﾟ☆ 完成間近バージョン実物で試しました。 0.31秒でパーフェクトですｗ
ｷﾘｷさん＞♪(*~ё~)ﾉ 修正ｺｰﾄﾞ試してみました。 ちゃんと重複分も表示されましたｗ ただ問題は 沢山のデーターで試すとPCが固まってしまって 応答していません・になってしまうです。 れいままのPCアップデートしていないからのようです。 なので れいままの家のPCで試すときは データーが少ないものむきのようです。 ｷﾘｷさん 凄い・・・ れいままも いつか 色々作れるようになりたいです。
皆様 ご協力ありがとうございます。 （れいまま）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.