Excel VBA Changeイベントのコードで実行しない件について

いつもお世話になっております。
あるシート（発着地一覧）に　A列：都道府県　B列：都市名　C列：地名　のマスタリストが3000行近くあります。
もう一つのシートに表があって（A列は日付）　B列のドロップダウンリストで都道府県を選択→C列でB列で選んだ都市名の候補のドロップダウンリスト→D列でC列で更に絞られた地名のリストから選びたいです。

ある方（いつも隣にITのお仕事様）のブログを参考にして下記コード（B列→C列の部分だけ）を書いてみましたが、B列で府県を選んでもC列にリストの候補が現れません。

どこがいけないのかご指摘をいただければ有難いです。

Dim rngSearch As Range
Dim i As Long
Dim strAdr As String
Dim rngResult As String



Set myRange = Worksheets("発着地一覧").Range("A1").CurrentRegion '発着地一覧の検索範囲をセット


With ActiveSheet

If Target.Column = 2 And Target.Row > 9 Then 'ドロップダウンリストの文字列を選択したら

Set rngSearch = myRange.Find(What:=Target.Value, LookAt:=xlPart) '都道府県を検索

Application.EnableEvents = False

If Not rngSearch Is Nothing Then
i = 2
With Worksheets("発着地一覧")
'ヒットした値を発着地一覧のG列に格納
.Cells(i, 7).Value = .Cells(rngSearch.Row, 2).Value
End With

'ヒットした値のセルを退避
strAdr = rngSearch.Address

Do
Set rngSearch = myRange.FindNext(rngSearch)
If rngSearch Is Nothing Then
Exit Do
Else
If strAdr <> rngSearch.Address Then
i = i + 1
Worksheets("発着地一覧").Cells(i, 7).Value = Worksheets("発着地一覧").Cells(rngSearch.Row, 2).Value
End If
End If

Loop While rngSearch.Address <> strAdr

'名前付き範囲の範囲更新
rngResult = "Sheet25!" & "$G$2:$G$" & i

ActiveSheet.Names.Add Name:="都市検索結果", RefersTo:="=" & rngResult

End If

With .Range("C10:C2000").Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:="=都市検索結果"
End With

Application.EnableEvents = True

.Range("C10:C2000").Select

End If

End With

End Sub


お手数をおかけしますが、知恵を借りたく宜しくお願い致します。

No.1 回答者： Qchan1962 回答日時： 2021/02/22 19:00

こんばんは、

取敢えず、表題の
＞実行しない件について
は、デバッグ、エラー対処時に
Application.EnableEvents = True　
を実行しない為ではないでしょうか？
下記を実行してみて、
Sub a()
Application.EnableEvents = True
End Sub

No.2 回答者： fujillin 回答日時： 2021/02/22 21:00

こんばんは

反応しない事象に関しては、No1様の回答が正しそうに思われます。

上記以外に気が付いた点を以下に。
1.名前の定義の範囲を
＞rngResult = "Sheet25!" & "$G$2:$G$" & i
としていますが、シート名が違っていませんか？
雰囲気的には「発着地一覧」だと想像しますけれど・・・

2.入力規則の設定のリスト範囲は、どうやら名前の定義が利用できないようです。
上記の変数、rngResult にアドレスを正しく設定できていれば、直接
　Formula1:="=" & rngResult
として指定すれば、動作すると思います。

その他、直接ご質問には関係はありませんが、気になった点を。
一覧がどのような形で作成されているのか不明ですけれど…
・検索の際に、CurrentRegionからxlPartで検索していますが、表全体から検索することになってしまうので、似た名前などが存在すると、関係のないものがヒットしたり二重でヒットする原因になりそうです。
例えば、「津」（←一文字に限りませんが）で検索すると「大津」や「木津川」、「草津」更には町名の「浜大津」などもヒットしてしまうことになりそうです。
どの列が対応する列なのかわかりませんが、「都市名」なら「都市名」に対応する列のみから検索するようにしたほうが良いのではないでしょうか？

・また、検索する「都道府県」や「都市名」なども入力規則で選択しているのでしょうから、xlPartで検索する必要もなさそうに思います。
（常に完全一致しているはずなので。自由入力も許容しているのであれば別ですが）

・更に、一覧は単純なツリー構造になっていると想像しますので、事前にソートしてあれば、一つ一つを検索・抽出しなくても、入力規則のリスト範囲として直接「一覧の対象範囲」を指定すれば済むものと想像します。
（この方法のメリットは以下に示します）

・いらぬお世話ではありますが、入力規則の指定をするのに、「C10:C2000」と全セル（？）に指定しているようですが、これだとすでに入力済みの別の行のリストを再選択しようとすると、まったく関係のないリストが表示されることになります。
Targetの行に関して指定するだけで十分のように思われます。
とは言っても、ご提示のようにG列に抽出する方法だと、Target行にだけ指定しても、抽出内容が変わってしまっているため、他の行の内容も変わってしまうことになりますが、前述のように一覧の範囲を直接指定する方法をとれば、各行でそれぞれ関連の正しさが維持されるようになると考えられます。

この回答へのお礼

ご回答ありがとうございます。返信が遅くなり申し訳ございません。
非常に詳しく問題点を書いてくださってありがとうございます。
大の初心者として、恥ずかしい限りです。
教えてくださった問題点を一個ずつ見て行ってまた御礼と報告をさせていただきたいと思います。

お礼日時：2021/02/24 10:01

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2021/02/23 00:15

#1です

＃２様が既に指定されている通り、まだ様々の問題をはらんでいるように思います。
（そのような目的では無いと思いますが）
C10:C2000の範囲に入力規則を設定されるコード内容ですが、
入力規則は所謂、UIだと思います。2000近くも入力させると言うような事であれば、非常に運用しにくいのでは無いかと思います。

どこまでをユーザーにさせてどこからVBAで処理するかのすみ分けを
再構築された方が良いように思います。
ところで、問題があるものも（B9入力で作成後B10に違う値で実行されるとB９作成時のデータが書き替えられるなど）下記で
With Worksheets("発着地一覧")
.Cells(i, 7).Value = .Cells(rngSearch.Row, 2).Value
End With
を
.Cells(i, 7).Value = Worksheets("発着地一覧").Cells(rngSearch.Row, 2).Value
として　ActiveSheetに書き出す。（2か所）

rngResult = "Sheet25!" & "$G$2:$G$" & i　を
rngResult = "$G$2:$G$" & i
なら、
With .Range("C10:C2000").Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Formula1:="=都市検索結果"
End With
は通ると思います。が、Namesや範囲に書き出す必要がない
Collectionなどを作成した方が良いように思います。

記憶ですが、入力規則を設定したブックを（開く時）閉じる時に
エラーが出たような気がします。。
昔、作ったコードを確認すると閉じる時にすべての入力規則を削除するコードがあります。。（これについては、試していないので確かでは無いのですが）

この回答へのお礼

2回の渡ってご回答いただきまして、ありがとうございます。返信が遅くなり申し訳ございません。
参考書とネットで試行錯誤しながら、書いたもので、ここに書くのみ恥ずかしかったのですが、とても分かりやすくコード迄修正てくださってありがとうございます。
お二人のご回答見ながら修正し、結果を改めて返信させて頂きたいと思います。

お礼日時：2021/02/24 10:06