『複数の入力規則をVBAで連動させる(INDIRECT関数・名前の定義以外で）』（れもん） 初めて質問させていただきます。 検索で探したのですが、回答につながる質問・回答が見つけられませんでしたので、既出の場合は申し訳ございません。 3つのプルダウンリストを連動させたいと思っております。 掲題にもあるのですが、名前の定義やINDIRECT関数では困難でした。 （リストに表示させたいものが「項目」ではなく、アンケートのような長い文章であり、（）や・を利用しているため） 例） B列：大分類　⇒　C列：中分類　⇒　D列：小分類 B列で「トラブル」などの短い項目を選択⇒C列で「クレームで揉めた(受電・窓口)」や「誤って案内・手続きをした」等の記号を含む文章⇒さらにD列で詳しい文章（C列と同様の文章） B列で選ぶ内容によってC列の項目は変わります。同様に、C列で選ぶ内容によってD列の項目が変わります。（項目の数は1〜6つです） リストシートは別途作成しております。（B列⇒C列用のリストと、C列⇒D列用のリスト(２)） ※リスト・リスト(2)共に、Ａ列には項目・文章、Ｂ列以降にＡと合致した場合のドロップダウンリストの内容としております。 自分であらゆるページを参考にしながら作成してみたのですが、Ａ列⇒Ｂ列はうまくできましたが、Ｂ列⇒Ｃ列が出来ませんでした。 可能であればどなたかご教示いただけますでしょうか。 わかりにくい質問で申し訳ございませんが、何卒よろしくお願い申し上げます。 念のため,私が作成したものを下記にコピー＆ペーストさせていただきます。 Ｅｘｃｅｌは2003です。 Private Sub Worksheet_Activate() Dim i As Long, N As String On Error GoTo TRAP N = "" For i = 1 To Worksheets("リスト").Cells(Rows.Count, 1).End(xlUp).Row N = N & "," & Worksheets("リスト").Cells(i, 1).Value Next N = Right(N, Len(N) - 1) With Columns("B").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=N End With S = "" For l = 1 To Worksheets("リスト(2)").Cells(Rows.Count, 1).End(xlUp).Row S = S & "," & Worksheets("リスト(2)").Cells(l, 1).Value Next S = Right(S, Len(S) - 1) With Columns("C").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=S End With TRAP: End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, j As Long, N As String On Error GoTo TRAP If Target.Column > 4 Or Target.Row = 1 Then Exit Sub N = "" For i = 1 To Worksheets("リスト").Cells(Rows.Count, 1).End(xlUp).Row If Target.Value = Worksheets("リスト").Cells(i, 1) Then For j = 2 To Worksheets("リスト").Cells(i, Columns.Count).End(xlToLeft).Column N = N & "," & Worksheets("リスト").Cells(i, j).Value Next End If Next For l = 1 To Worksheets("リスト(2)").Cells(Rows.Count, 1).End(xlUp).Row If Target.Value = Worksheets("リスト(2)").Cells(l, 1) Then For k = 2 To Worksheets("リスト(2)").Cells(l, Columns.Count).End(xlToLeft).Column S = S & "," & Worksheets("リスト(2)").Cells(l, k).Value Next End If Next N = Right(N, Len(N) - 1) If Target.Column = 2 Then With Target.Offset(0, 1).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=N End With End If If Target.Column = 3 Then With Target.Offset(0, 1).Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=S End With End If Exit Sub TRAP: N = "" For i = 1 To Worksheets("リスト").Cells(Rows.Count, 1).End(xlUp).Row N = N & "," & Worksheets("リスト").Cells(i, 1).Value Next With Columns("B").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=N End With S = "" For l = 1 To Worksheets("リスト(2)").Cells(Rows.Count, 1).End(xlUp).Row S = S & "," & Worksheets("リスト(2)").Cells(l, 1).Value Next With Columns("C").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=S End With End Sub ---- 説明では B列、C列、D列　の連携のようですが、 TRAP の部分のコードを見るとB列、C列への処理のようです。 B列は最初に選ぶ選択ですから、処理は不要だと思うのですが、初期化処理では 何をしているのでしょうか。 いずれにせよ、リストシートの構成とB列で選択した項目ときに何をしたいか をもう少し詳細に説明したらどうかと思います。 (Mook) ---- リストとフィルタオプションの設定を利用したサンプルコード 入力規則を設定するシートのB列にはすでに入力規則が設定されているとします。 「LIST」というシートと「TEMP」というシートを用意します。 LISTシートには下記のようなリストを用意します。 　 A B C [1] 内容 リスト１ リスト２ [2] クレーム 品質 腐敗 [3] クレーム 品質 見た目が悪い [4] クレーム 品質 異物混入 [5] クレーム 品質 まずい [6] クレーム 価格 高い [7] クレーム 価格 少ない [8] クレーム サービス 店員の対応が悪い [9] クレーム サービス 利用しにくい [10] 問合わせ 配送 到着時間 [11] 問合わせ 配送 配送日変更 [12] 問合わせ 支払 支払い方法の確認 [13] 問合わせ 支払 運賃の確認 [14] 問合わせ 支払 誤送金 [15] 問合わせ 商品 説明 [16] 問合わせ 商品 原材料の問い合わせ [17] 問合わせ 商品 重量、容量 　 TEMPシートはフィルタオプションで必要なリストを抽出する役目です。 次のように入力しておきます。（見出しだけです） A B C D E F [1] 内容 リスト１ リスト２ 内容 リスト１ [2] 　 入力規則を設定しているシートのシートモジュールへ下記をコピーしてください。 Private Sub Worksheet_Change(ByVal Target As Range) Dim rng1 As String, rng2 As String Dim wsTmp As Worksheet If Target.Row > 1 Then Set wsTmp = Worksheets("TEMP") Select Case Target.Column Case Is = 2 rng1 = "E1:E2" rng2 = "B1:B2" Case Is = 3 rng1 = "E1:F2" rng2 = "B1:C2" End Select Select Case Target.Column Case Is = 2, 3 With Target.Offset(0, 1).Validation .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=SetStr(wsTmp, rng1, rng2, Target) End With End Select End If End Sub Private Function SetStr(ByVal ws As Worksheet, ctrRng As String, cptRng As String, tgtRng As Range) Dim myRow As Long, i As Long Dim s As String With ws .Range("A2:C65536").ClearContents Select Case tgtRng.Column Case Is = 2 tgtRng.Offset(, 1).Resize(, 2).ClearContents .Range("E2").Value = tgtRng.Value Case Is = 3 .Range("E2").Value = tgtRng.Offset(, -1).Value .Range("F2").Value = tgtRng.Value End Select Application.DisplayAlerts = False Sheets("LIST").Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range(ctrRng), _ CopyToRange:=.Range(cptRng), _ Unique:=True Application.DisplayAlerts = True myRow = WorksheetFunction.CountA(.Columns(tgtRng.Column)) For i = 2 To myRow s = s & "," & .Cells(i, tgtRng.Column).Value Next i SetStr = Right(s, Len(s) - 1) End With End Function 　 ＞B列は最初に選ぶ選択ですから、処理は不要だと思うのですが、 B列のリストも随時増えるのかな？ 御提示のコードは走らせていないのでよくわからないのですけど。 (みやほりん)(-_∂)b ---- Mookさん＞ 書き込んでくださってありがとうございました。 元々別のファイルで使用していたＶＢＡで、Ｂ列を選択したらＣ列にリスト、Ｃ列を選択したらＢ列にリスト(Ｂ列を選択したらＣ列にリスト表示されるものと同じ)・・・という相互作用の動作でした。 ご指摘いただいたように、なぜＮを初期化するのだろうか・・・？と思っておりましたが、よくよく考えてみれば、Ｂ列とＣ列のどちらを選択しても対応するセルに表示されるリスト内容を同じにするためには初期化は必要だと気付きました。 そのＶＢＡを元に作成したのですが、ＶＢＡ勉強し始めレベルの私は、単純に「Ｃ列を選択⇒Ｂ列にリスト」の部分を「Ｃ列を選択⇒Ｄ列にリスト」にすればいいだけかと勘違いしておりました。 大変失礼いたしました。このような分りにくい質問にもご丁寧に書き込み、アドバイスいただきまして、本当に有難うございました。 ---- みやほりんさん＞ 書き込み＆アドバイスをわかりやすくいただき、ありがとうございます。 まさにみやほりんさんがアドバイスしてくださった通りのことを行いたかったのです！！ 早速走らせてみましたら・・・出来ました！！！ あと２点ご質問させていただきたいのですが・・・ Ｃ列リストは選択肢が1つしかないのに、その１つを選択するとＤ列には４通り等複数の文章より選択することになっている場合、Ｃ列選択時にはＤ列の文章の数だけ同じ文章がリストとして表示されます。 例）リストの内容として以下のようにドロップダウンリストで表示したい場合 　　Ｃ　　　　Ｄ 商品　　　説明 　　　　　　　原材料の問い合わせ 　　　　　　　重量・質量 の場合、Ｃ列を選択するとドロップダウンリストには商品、商品、商品とＤ列の数だけ同じ言葉がリストに出現するということです。 これは解決できるのでしょうか。 もう１点ですが、入力規則を設定したい列が現在はＢ，Ｃ，Ｄ列ですが、たとえばＨ，Ｉ，Ｊ列へ平行移動(Ａ列とＢ列の間に新規に列を増やした為結果的にＢＣＤ列が右へずれたということ）した場合、先ほどのＶＢＡのコードのどの部分を直したら対応できますでしょうか。 仕組み上難しいのであれば、ご教示いただきました内容で大満足です。 勉強始めの初心者がわかりにくい質問をさせていただきまして申し訳ありません。 よろしければ再度ご教示お願い致します。 ---- Private Function SetStr(ByVal ws As Worksheet, ctrRng As String, cptRng As String, tgtRng As Range) Dim myRow As Long, i As Long Dim s As String Application.EnableEvents = False　'★ With ws .Range("A2:C65536").ClearContents Select Case tgtRng.Column Case Is = 2 tgtRng.Offset(, 1).Resize(, 2).ClearContents .Range("E2").Value = tgtRng.Value Case Is = 3 .Range("E2").Value = tgtRng.Offset(, -1).Value .Range("F2").Value = tgtRng.Value End Select Application.DisplayAlerts = False Sheets("LIST").Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range(ctrRng), _ CopyToRange:=.Range(cptRng), _ Unique:=True Application.DisplayAlerts = True myRow = WorksheetFunction.CountA(.Columns(tgtRng.Column)) For i = 2 To myRow s = s & "," & .Cells(i, tgtRng.Column).Value Next i SetStr = Right(s, Len(s) - 1) End With Application.EnableEvents = True '★ End Function 　 検証不足でしたね。 ★印の部分が追加になります。 　 ＞もう１点 Target.Column　や　tgtRng.Column　が二つのプロシージャにそれぞれありますが、 この部分で「セルの内容が変更されたセル」の列番号を把握しています。 WorksheetFunction.CountA(.Columns(tgtRng.Column)) などはLISTシートと入力シートの相対位置関係で取得していますから、 列がずれてしまうとお手上げです。 　 そうした前提を元に作っているものですから、その意味では提示したコードは かなりタイトな条件（質問の通りのレイアウト）でしか動かないマクロです。 　 「どの部分を直したら」といわれれば、「そういう話なら作り直しかなぁ」 という気分ではあります。 （今日は時間がないのでできませんが） (みやほりん)(-_∂)b ---- みやほりんさん＞ VBA勉強し始めで、何を言いたいのかいまいちわかりにくい質問に対して分りやすく丁寧にご回答くださり、本当に有難うございます！！ 1件目は書き込んでくださったものをコピー＆ペーストして完成しました！！ 2件目は同様のドロップダウンリストを別のファイルにも使用したいと思っております。 まず1つ完成させることの出来たファイルでは、入力規則プルダウンリストがB列・C列・D列に設定でしたが、次のファイルはR・S・T列になります。 内容(リストに表示させる文言）は若干違いはありますが、形式は全く同様です。 リストの連動のさせ方も全く同じです。 あらかじめR列に入力規則のプルダウンリストを作成しておいて、それに応じてS列⇒T列という流れは、B列・C列・D列と同じです。 なので、割とシンプルに変更できるのかと思ってしまいました。 度々申し訳ありませんが、もしもお時間が許すようでしたらぜひ再度ご教示よろしくお願い申し上げます （れもん） ---- Const lstWsName = "LIST": Rem 元となる　LIST を　作成しておくシート名 Const tmpWsName = "TEMP": Rem AdvancedFilter を　設定するシート名 Const str1 = "E1:F2": Rem AdvancedFilter　の　CriteriaRangeに指定するTEMPシート　のセル範囲 Const str2 = "A1:C2": Rem AdvancedFilter　の　CopyToRangeに指定するTEMPシート　のセル範囲 Const strVldRng = "R:T": Rem 入力規則を設定するシートの列範囲 Private Sub Worksheet_Change(ByVal Target As Range) Dim rng1 As Range, rng2 As Range Dim chk1 As Long, chk2 As Long Dim wsTmp As Worksheet chk1 = Range(strVldRng).Cells(1).Column chk2 = Range(strVldRng).Cells(2).Column If Target.Row > 1 Then Set wsTmp = Worksheets(tmpWsName) Select Case Target.Column Case Is = chk1 Set rng1 = wsTmp.Range(str1).Resize(, 1) Set rng2 = wsTmp.Range(str2).Resize(, 2) Case Is = chk2 Set rng1 = wsTmp.Range(str1).Resize(, 2) Set rng2 = wsTmp.Range(str2).Resize(, 3) End Select Select Case Target.Column Case Is = chk1, chk2 With Target.Offset(0, 1).Validation .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=SetStr(wsTmp, rng1, rng2, Target, True) End With End Select Set rng2 = Nothing Set rng1 = Nothing Set wsTmp = Nothing End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim rng1 As Range, rng2 As Range Dim chk0 As Long Dim wsTmp As Worksheet If Target.Column = Me.Range(strVldRng).Cells(1, 1).Column Then If Target.Row > 1 Then Set wsTmp = Worksheets(tmpWsName) Set rng1 = wsTmp.Range(str1) Set rng2 = wsTmp.Range(str2).Resize(, 1) With Target.Validation rng1.Offset(1, 0).ClearContents .Delete .Add Type:=xlValidateList, _ AlertStyle:=xlValidAlertStop, _ Operator:=xlBetween, _ Formula1:=SetStr(wsTmp, rng1, rng2, Target, False) End With Set rng2 = Nothing Set rng1 = Nothing Set wsTmp = Nothing End If End If End Sub Private Function SetStr(ByVal ws As Worksheet, ctrRng As Range, cptRng As Range, _ tgtRng As Range, flg As Boolean) As String Dim myRow As Long, i As Long Dim s As String Application.EnableEvents = False cptRng.CurrentRegion.Offset(1, 0).ClearContents Select Case tgtRng.Column Case Is = Me.Range(strVldRng).Cells(1).Column tgtRng.Offset(, 1).Resize(, 2).ClearContents If flg Then ctrRng(2, 1).Value = tgtRng.Value Case Is = Me.Range(strVldRng).Cells(2).Column ctrRng(2, 1).Value = tgtRng.Offset(, -1).Value ctrRng(2, 2).Value = tgtRng.Value End Select Application.DisplayAlerts = False Sheets(lstWsName).Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=ctrRng, _ CopyToRange:=cptRng, _ Unique:=True Application.DisplayAlerts = True With ws myRow = WorksheetFunction.CountA(.Columns(cptRng.Cells(cptRng.Count).Column)) For i = 2 To myRow s = s & "," & .Cells(i, cptRng.Cells(cptRng.Count).Column).Value Next i End With SetStr = Right(s, Len(s) - 1) Application.EnableEvents = True End Function 　 モジュールの先頭部分に定数で各パラメータを設定しています。 ただし、str1　str2は融通性がありません。目立つところに覚書として 表示してある程度のものです。 　 シート名および入力規則を設定する列範囲名をこの部分で規定できます。 元となるシートが整備されていれば、第一選択項目も自動でリストを作成します。 　 (みやほりん)(-_∂)b ---- みやほりんさん＞ ありがとうございます！！ 第一項目も含めてドロップダウンリストがＶＢＡで全て実行されました！ みやほりんさん、本当にすごいですね！！ 私も少しずつＶＢＡを勉強して、いつか自分できちんと組み立てられれば・・・と思います。 私の分りにくい説明、質問に丁寧に応えてくださり、本当に、本当にありがとうございました。 （れもん） ---- 連動する入力規則リストはよく質問に上がりますし、 手元で使っているものも作り直したかったのでこれを機会に 汎用で使える仕組みのひとつが作れたら、という発想で作ってみました。 　 もうちょっと 手をかけてみたい気もしますが・・・。 (みやほりん)(-_∂)b