[[20110513143646]]　『複数の入力規則をVBAで連動させる(INDIRECT関数・』（れもん）　ページの最後に飛ぶ

『複数の入力規則を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

コメント返信：

[ 一覧(最新更新順) ]

[[20110513143646]] 『複数の入力規則をVBAで連動させる(INDIRECT関数・』（れもん） ページの最後に飛ぶ

[[20110513143646]]　『複数の入力規則をVBAで連動させる(INDIRECT関数・』（れもん）　ページの最後に飛ぶ