Results of 1 - 1 of about 37653 for IF (0.007 sec.)
- [[20061222213534]]
- #score: 1592
- @digest: ca047946440869c3ebfd15a668849714
- @id: 27516
- @mdate: 2006-12-28T12:32:30Z
- @size: 40100
- @type: text/plain
- #keywords: rex (86763), adkey (65903), 旭町 (54835), 井町 (54835), 足柄 (54835), 市( (52054), 藤沢 (45346), 丁目 (44094), myflg (36200), 当店 (33499), 【bo (29084), 川県 (26438), pattern (23698), 神奈 (17733), returnboolean (16694), 奈川 (16643), 弥太 (14217), maxcol (13355), msforms (10529), data (9778), replace (8994), execute (8967), tbl (8923), xlprevious (8651), vbscript (7998), flag (7669), vbnarrow (7356), flg (6925), regexp (5869), 太郎 (5588), strconv (5329), 住所 (4778)
- 『ユーザーフォームについて』（れいまま）
こんばんは。 またまた教えてください<(__*)＞（また れいままだよ〜って思った方ごめんなさい） 今、ユーザーフォームについて勉強しています。 下記のような入力フォームのコードを作ってみました。 （Sheet1） A B C D E F G H I J K L M N O P 番号 伝票番号 お客様のお名前 月 日 ☆ 時間 店所コード 担当店 電話番号 携帯番号 郵便番号 住所@ 住所A 事前連絡 備考 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行単位です。 +1 -1ですね。 なるほど。思いつかなかったです。 これが完成すれば 色々な入力作業に応用できます。 画面が どんなに横に長くても画面を移動しなくてすみますから。 入力作業の時間短縮になります。 ありがとうございました（嬉 （れいまま） ---- 戻すのは確認の為に表示するだけですか?それとも一部を入力し直す為ですか? 戻るのが1つ前までの限定であれば問題ないと思いますが、複数行も戻る場合は新規 に入力するときに最終行を取得するか最終行を保持しておく必要があるでしょうね。 そうしないと入力済みの行を上書きしていってしまいます。 （やっちん） ---- やっちんさん＞こんにちは。 確認が主ですが、確認作業で間違いがあったら訂正したいですね。 新しくコマンドボタンを作って修正できるようにした方がいいかもしれないですね。 ありがとうございます。 （れいまま） ---- えーーと、 最下行のセル、アドレス、または行などを一度変数に格納してやれば、 どこに移動しようと、戻れますよね? (seiya) ---- えと、このスレに関係無い事ですけど、ごめんなはれや。 一応出来上がりましたんで、検証頼んます。（例の所） バイオレットで塗ってあるセルは完全一致が不可能なデータデスワ。 それと正規のデータは横のセルに逃がしてあります。本データは曖昧な数値になっとり ますもんで、違いがハッキリしたデータで検証すべきと思いましてナ。 ただまぁ、元に戻す際は今一度再確認お願いします。 住所を入力したら半角に変換にするのをお忘れ無く。 住所が全く同じやと、空白行で表示されます。 （弥太郎） ---- seiyaさん＞こんばんは。o(^-^ o ) 全て変数に格納することで 何番目を参照しても新しい行に 移動できるということですよね。 れいまま 変数を自分のものにする良いチャンスだと思っています。 だから 頑張りますw ちなみに ユーザーフォームの内容は No【BOX1】 伝票番号をハイフォンなしで入力してください 【BOX2】 お客さまの名前を入れてください 【BOX3】 日にち 時間を選んでください 【BOX4】月【BOX5】日 【BOX6】【BOX7】 1 AM 2 PM 3 FREE 担当店を入力してください 電話番号 【BOX8】 【BOX10】 【BOX9】店 【BOX11】 郵便番号を入れてください 【BOX12】 住所を入れてください 事前連絡 【BOX13】（郵便番号を入れると表示されます） 【BOX15】【BOX16】 【BOX14】（番地など手入力します） 1 ○ 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 ---- 弥太郎さん♪ メリークリスマス☆ ありがとうございます。 とっても嬉しい クリスマスプレゼントになりました。 早速コード入れ替えます。 今日は気持ち悪くて早退してしまったので まだ 試していないのです。明日 試してみますね。 薬もらったので 明日は大丈夫だと思います。 （れいまま） ---- >今日は気持ち悪くて早退してしまったので それは、それは・・・お大事に。 どっかの陰から弥太郎の顔を覗いた所為で・・とかやおまへんわなぁ・・・（笑 （弥太郎） ---- 弥太郎さん 試してみました。 遅くなってすみません。 ＞それと先方とのやりとり上全角がベターやと思いますんで、変数上だけで半角に変換検 索するよう書き換えときました と言うことは、半画に変換しなくても良いということですよね。 そのままVer4を試してみました。 結果ですが・・・ ほぼ 表示されました。が・・・ [壁]_・)チラッ なんとも もうしあげにくいのですがm(。≧Д≦。)m 作業シートを半画に変換してVer1で試したほうが より多くの店所を表示しました。 弥太郎さんが 時間をかけてくださったのに・・・ o(;△;)o 半画へ変換してからもVer4を試しましたが 結果は同じでした。 どちらにも共通して店所を表示しなかったのが ○ヶ○という住所で ○ケ○と添付されてくるものです。 こればっかりは 半画変換しても表示されませんでした。 Ver1では この文字の場所1箇所だけで後はパーフェクトでした。 Ver4は13個表示されませんでした。 な〜ぜ〜??? 手の込んだほうが表示されないの???といった心境です。 全部パーフェクトでしたと嘘の報告でもと思ったのですが 悩んだけど 本当のこと書きました。 "(/へ\*) 弥太郎さん ありがとうございます。 感謝の気持ちでいっぱいです。（真実） （21時まで会社で仕事していた れいまま） ＞それは、それは・・・お大事に。 ありがとうございます。今日は元気に仕事しましたw ＞どっかの陰から弥太郎の顔を覗いた所為で・・とかやおまへんわなぁ・・・（笑 弥太郎さんにお会いしたら元気もりもりですw 23:20追加 ---- 気になったところをもう1つ コード表示すると Private Function c_flg(ByVal d_1 As String, ByVal d_2 As String) As Boolean の場所の上に線が引かれています。 もしかして 作動していないのかも・・・? （れいまま） ---- >全部パーフェクトでしたと嘘の報告 は、止めておくんなはれ。乗りかかった船ですから、この件に関してはヤケクソにな ってでも仕上げますワ。（笑 一応下のコードでヶケは解消する（多分）と思うんですが、担当店一覧の松が丘とか ひばりが丘、星が丘とかは星ヶ丘などと先方から送りつけてきますんやろか? それやと、それに対応するよう加えなあきまへんもんで・・・ も一つ旭町1丁目3-4 は検索上旭町1丁目としとりますけど、旭町1-3-4等 丁目省略方で送付してくるばやいはありまへんか? （弥太郎） 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))ﾟ・。 ありがとうございます。 ＞も一つ旭町1丁目3-4 は検索上旭町1丁目としとりますけど、旭町1-3-4等 ＞丁目省略方で送付してくるばやいはありまへんか? ↑ありでございます。┏（_□_:）┓ 送られてくる住所はお客様が書いたものを担当者が入力したと 思われます。 それを そのまま送ってくるのです。担当者は一人ではないと思うので 入力方法が統一されていないのだと・・・ しかも お客様によっては ○番地○と申告する方もいれば ○ー○と申告される方もいます。 なので難しいのだと思います。 (誰も 住所からマクロでお店を表示させようとしているなんて 思いもしないと思うので 住所が分かればいいくらいの記載なのです 実際 出来る人なんて れいままの会社にはシステム開発以外ほとんどいないと思われます） 早速試してみます 弥太郎さん ありがとうございます。 （れいまま） ---- 弥太郎さん 報告です。 試してみました。 表示されない住所は 海-東梶ヶ谷 厚-上荻野 相-津久井町 藤-善行 足-松田町 大-中央 平-代官町 相-弥栄 藤-片瀬 相-田名 足-中井町 でした。 ちなみに Ver1は表示されました。 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("h2").Resize(.Range("h" & 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 （れいまま） ---- どっかマクロ触りましたぁ? 当方では全て正常に拾い出しとりますがなぁ?? 念のためこんなデータ（全角）も正確に拾いまっせ。 神奈川県海老名市東梶ヶ谷5-3 神奈川県海老名市東梶ケ谷4-3 も一遍コピペしてくらはい。ヶ、ケ、は対処しとりますが 「が」とケ、ヶと同等に 扱うのには対処しとりまへん。 （弥太郎） '--------------------- 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は〜の有る無しを判断します。要するにこのマクロにひっついた関数みたいな もんですわ。 例えば厚 - 旭町3丁目はc_flgはTrueで、c_flgはFalseを、泉町はc_flg=False,d_flg =Trueを、また東梶ヶ谷は両方に属しまへんからc_flgもd_flgもFalseで処理されるん ですワ。 （弥太郎） ---- う〜ん・・・ やはり表示されないないのです。 なぜ??? 海-東柏ケ谷 も表示されないです・・・ （れいまま） ---- ほならあそこへUPしときますワ。あれで試してみてくらはい。 （弥太郎） ---- ありがとうございます。 同じのUPしましたので 弥太郎さんお試しください。 （れいまま） ---- 224 神奈川県海老名市東柏ケ谷6丁目13- 224 神奈川県海老名市東柏ケ谷3丁目4- 019 神奈川県厚木市上荻野4260 神奈川県相模原市津久井町長竹1785-1 神奈川県藤沢市善行1- 035 神奈川県藤沢市善行1- 神奈川県足柄上郡松田町神山25- 神奈川県大和市中央6丁目8- 520 神奈川県大和市中央6丁目8- 140 神奈川県平塚市代官町35- 608 神奈川県相模原市弥栄2丁目16- 011 神奈川県藤沢市片瀬5丁目2- 564 神奈川県相模原市田名5581 神奈川県足柄上郡中井町井ノ口1574ー 結果は以上ですワ。 津久井町長竹は津久井町の後数値で検索しとりますから（中井町、松田町も同じ）一致 しまへん。 善行は同一住所ですから一つしか拾いまへん。同一住所に2回に分けて発送するのは 非現実的ですわなぁ。2個口とか3個口で事足りますからなぁ。 善行1-2 善行1-3と入力して試すとお分かりになろうかと おもわれます。中央6丁目8も同じ事が言えます。 ところで、実際に松田町神山とか中井町井ノ口とかが（町の後が数値でない）拾えない のは考えてみますワ。 （弥太郎） ---- そうそう、その同一住所が頻繁にあるんなら空のセルを検索してそこを埋めるマクロを 追加してもよろしいで。 （弥太郎） ---- 弥太郎さん＞ありがとうございます。 一回に発送なのですが 同じ名前・住所で伝票番号違いが沢山あるのです。 Ver1で拾ってくれるのとは なにが違うのでしょうか? （れいまま） 衝突してしまいましたw 頻繁にあります。 ぜひ お願いします。 広告の住所とかひろって 架空のでまた 試してみます。 実物データーは会社から持ち出せないので・・・ ↑ 適当にいれた住所ですが 実際の方いらしたらごめんなさいね。 ---- もう一回ようくみたら 表示されないのは重複しているやつですね。 ↑ 説明納得しました。 (れいまま） ---- ↑にVer5として中井町井ノ口云々を対処、同住所も拾うよう変更しときました。 また、アラ捜してくらはい。 Ver1との違いは検索方法を逆にして空振りをなくしたんですワ。あれ、〜とか 他とか に対応しとりまへんで、あくまで曖昧検索ですから100%はとても無理です。 えらいコードが長くなってしまいましたなぁ（笑 完全主義者はつらい・・・（弥太郎） ---- 弥太郎さん♥ ありがとうございます。 弥太郎さんを独占した気分で とってもいい気持ちです（笑 これから 日々作業をするなかで 何か不具合が生じたら ぜひ お願いします。 れいままにはレベル高すぎて このマクロ理解できないです・・・（汗 今からケーキを買いに行きます。 クリスマスは具合悪くて食べれなかったのでw 夕飯食べてから試します。 ありがとうございます。 （れいまま） そうそう、 明日朝礼当番が回ってくることになりました。 あの日が昇る〜の話させていただきますw ---- >弥太郎さんを独占した気分で とってもいい気持ちです（笑 そ・そんな〜 σ(^o^;)の、ししょ〜ですねんでぇw 試しに作ってみました。 が、時間がかかるようです。。。 まぁ、勉強って事でwww 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 を拾い読みしときまひょ。（笑 （弥太郎） ---- キリキさんw＞こんばんは〜 嬉しいです。れいまま作れないです・・・（尊敬） 時間はかかってもかまいません。 気持ちがとっても嬉しいです。 自分が質問したことに対して 一生懸命やってくださった全ての方に ありがとうの気持ちが必要なのだと思います。 ご飯食べてから試してみますね。 今日は買い物に行ってお財布忘れて・・・ ご飯が遅くなってしまいました 弥太郎さん＞ 本のことをおっしゃりたいのかしら? 日はまた昇るって本ありましたよね?たしか・・・ 話かわって Ver5の件ですが 同じのが空白だったような・・・ ご飯の支度しながら試したので（汗 あとでゆっくり見てみます。 れいままも いつか弟子入りさせてください（笑 そしたら とりっこにならい?（笑 （れいまま） ---- キリキさんw 実物で試してみましたw 近隣の営業所で試しました。 コメントが出てきました。 やはりエラーが出ましたかって。 おちゃめなコメントだと思います。 （れいまま） 弥太郎さん＞ Ver5確認しました。 藤-善行の重複分と 相-田名の重複分以外 全て表示されています。 ---- ちこっと上記コード修正しました。 時間があるときに試してもらって、何が駄目か教えて〜 （キリキ）(〃⌒o⌒)b ---- 完成間近バージョンUPしますた。 お試しあれ。 （弥太郎） ---- キリキさん＞ありがとうございます。 了解しました。 弥太郎さん＞ 楽しみにしています。 早速朝礼でつっこまれました（笑 一番えらい人に二度もw （れいまま） ---- 弥太郎さん＞ 。・:*:・ﾟ★,。・:*:・ﾟ☆ very d(*⌒▽⌒*)b good 。・:*:・ﾟ★,。・:*:・ﾟ☆ 完成間近バージョン実物で試しました。 0.31秒でパーフェクトですw キリキさん＞♪(*‾ё‾)ノ 修正コード試してみました。 ちゃんと重複分も表示されましたw ただ問題は 沢山のデーターで試すとPCが固まってしまって 応答していません・になってしまうです。 れいままのPCアップデートしていないからのようです。 なので れいままの家のPCで試すときは データーが少ないものむきのようです。 キリキさん 凄い・・・ れいままも いつか 色々作れるようになりたいです。 皆様 ご協力ありがとうございます。 （れいまま）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/200612/20061222213534.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97036 documents and 608025 words.
訪問者：