入力規則（3階層選択式入力）　味はソコソコ？Excel Tips（しお味）

入力規則その3

入力規則その2では、主に2段階の選択式の入力に関する例を見てきましたが、ここではさらに3段階の入力規則について考えます。 2段階までならば、vbaなんか使わなくても参照元の名前とINDIRECT関数で出来ましたが、3段階になると、参照元データの選択肢が飛躍的に多くなり、名前を付けてやるのは現実的に難しくなってきます。
3階層の場合は参照元データの表の構成が少し複雑になってきます。2段階の場合は、1階層目のデータは縦並びで、2階層目はの1階層目に関連するデータは、横並びに出来ますが、3階層の場合は、1階層目、2階層目は縦並びで、3階層目が横並びになります。参照データは、今回の説明の様に1階層目を縦並びにしないで横並びにする方法も、もちろんありますがトータルでのデータの構成は同じような感じになります。

2階層の参照元データの例	3階層の参照元データの例	3階層の入力例

※この3階層の参照データー表は、全ての階層で動的にカンマ区切りの文字列を作っているので、参照元のデータの変更が非常に容易で、この表のフォーマットに従った構造であれば単純に、データ追加や削除をするだけで、選択肢に反映されます。

●3階層入力規則の流れ
［参照元の表の作成］
1階層目（縦並び、2階層目の数だけ間をあける）
2階層目（縦並び）
3階層目（横並び）

(vbaでの処理の流れ）
1）1階層目の入力規則の設定
参照データのカンマ区切り文字列化（空白の部分をのぞいて作成）

1階層目の選択
2）1階層目のデータに対応する2階層目のカンマ区切り文字列の作成
3）2階層目の入力規則の設定

2階層目の選択
4) 2階層目のデータに対応する3階層目のカンマ区切り文字列の作成
5）3階層目の入力規則の設定

3階層目の選択

上記の様に各選択支に選択状況に応じて、その次の参照データの文字列を作ってその文字列を次の段階の入力規則に反映させるように逐次処理が進むことになります。
ここでは、固定入力枠での3階層入力の場合と、表形式での3階層入力の2つの形式を説明します。

3階層入力規則の例（固定枠形式）

この例は、くだものの、名前、品種、産地の情報を3階層で選択していきます。
選択肢を変更すると、その下流の入力肢の前のデータはクリアされます。

●ここでの基本的モジュール
（標準モジュール）
getnt3（1階層目）
getit1（2階層目）
getit2（3階層目）
clr10（解除）
（シートモジュール）
Private Sub Worksheet_Change(ByVal Target As Range)
　　　：

3階層入力規則の1階層目（固定枠）

  Sub getnt3()    '■■■3階層の入力規則　1階層目■■■（固定枠入力）

  Dim lrows As Integer
  Dim items1 As String
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet

  Set ws1 = Worksheets("main2")
  Set ws2 = Worksheets("pdata2")

  '1階層目のデータ取得(文字列化）/////////////////////////////////////////////////

  '1列目の最終行取得
  lrows = ws2.Cells(Rows.Count, 1).End(xlUp).Row

  'アイテムの文字列化（コンマ区切り）
  For k = 1 To lrows

    If ws2.Cells(k + 1, 1) <> "" Then  '空白ではない項目をコンマを挟んで文字列に蓄積

       items1 = items1 + "," + ws2.Cells(k + 1, 1)

    End If

  Next

  items1 = Right(items1, Len(items1) - 1)    '始めのコンマの削除

  'ws1.Cells(10, 5) = items1

      '入力規則1階層目の設定/////////////////////////////////////////////////////
      With ws1.Range("B4").Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items1
      End With

  End Sub

3階層入力規則の2階層目（固定枠）

  Sub getit1()    '■■■3階層の入力規則　2階層目■■■（固定枠入力）

  Dim rng As Range
  Dim tchr1 As String             '1階層目の文字列収容
  Dim items2 As String            '2階層目の文字列収容(カンマ区切り）
  Dim items3 As String            '3階層目の文字列収容(カンマ区切り）
  Dim itrowe As Integer           '2階層目の最終行
  Dim fnrowt As Integer           '1階層目の行（検索文字と合致）
  Dim fnrowe As Integer           '合致した行から下へ検索した場合の空白でない最初の行（1列目：pdata2）
  Dim ws1 As Worksheet            'ワークシート
  Dim ws2 As Worksheet            'ワークシート

  Set ws1 = Worksheets("main2")   'ワークシート名の収容
  Set ws2 = Worksheets("pdata2")  'ワークシート名の収容

  ws1.Range("c4:d4") = ""

  '1階層目のデータ取得
  tchr1 = ws1.Cells(4, 2)

  '1階層目の最初の行数
   Set rng = ws2.Columns(1).Find(What:=tchr1, LookAt:=xlWhole)

  '2階層目の最終行
  itrowe = ws2.Cells(Rows.Count, 2).End(xlUp).Row

  '1階層目の行（検索文字と合致）
  fnrowt = rng.Row

  '1階層目に対応する2階層目の範囲を取得（最初の行、最後の行）***************
  For k = fnrowt + 1 To itrowe

   If ws2.Cells(k, 1) <> "" Then

         fnrowe = k - 1
         Exit For

       Else

         fnrowe = itrowe

   End If

  Next
  '*************************************************************************

  'fnrowt        '1階層目の範囲（最初の行）
  'fnrowe        '1階層目の範囲（最後の行）
  'itrowe        '2階層目の最下行

  '2階層目のアイテムを文字列化（カンマ区切り）******************************

  For k = fnrowt To fnrowe

     items2 = items2 + "," + ws2.Cells(k, 2)

  Next

  items2 = Right(items2, Len(items2) - 1)    '最初のカンマを削除

  '*************************************************************************

      With ws1.Range("D4").Validation        '3階層目の入力規則削除
          .Delete
      End With

   '入力規則2階層目の設定/////////////////////////////////////////////////////
      With ws1.Range("C4").Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items2
      End With

  End Sub

3階層入力規則の3階層目（固定枠）

  Sub getit2()  '■■■3階層の入力規則　3階層目■■■（固定枠入力）

  Dim rng As Range                '2階層目の文字findの検索結果収容(pdata2)
  Dim tchr2 As String             '2階層目の文字収容
  Dim fnrowt2 As Integer          '2階層目の行（検索文字と合致)の収容
  Dim fnclmt2 As Integer          '検索文字と合致した行の終端（カラム数）
  Dim items3 As String            '3階層目の文字列収容(カンマ区切り）用

  Dim ws1 As Worksheet            'ワークシート
  Dim ws2 As Worksheet            'ワークシート

  Set ws1 = Worksheets("main2")   'ワークシート名の収容
  Set ws2 = Worksheets("pdata2")  'ワークシート名の収容

  ws1.Range("d4") = ""

  '2階層目のデータ取得
   tchr2 = ws1.Cells(4, 3)

  '2階層目の行数
   Set rng = ws2.Columns(2).Find(What:=tchr2, LookAt:=xlWhole)

  '2階層目の行（検索文字と合致）3階層目の行数も同じ
   fnrowt2 = rng.Row

  '検索文字と合致した行の終端（カラム数）
   fnclmt2 = ws2.Cells(fnrowt2, Columns.Count).End(xlToLeft).Column

  '3階層目のアイテムを文字列化（カンマ区切り）******************************

  For k = 3 To fnclmt2

     items3 = items3 + "," + ws2.Cells(fnrowt2, k)

  Next

  If Len(items3) - 1 > 0 Then

      items3 = Right(items3, Len(items3) - 1)    '最初のカンマを削除

  'ws1.Cells(10, 3) = items3

   '入力規則3階層目の設定/////////////////////////////////////////////////////
      With ws1.Range("D4").Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items3
      End With

  End If

  End Sub

入力規則の解除

  Sub clr10()  '入力規則_3階層のリスト選択の設定の解除（固定枠入力）

      Worksheets("main2").Range("B4:D4") = ""

      With Worksheets("main2").Range("B4:D4").Validation

          .Delete

      End With

  End Sub

選択肢の変化の検出（シートモジュール）

  Private Sub Worksheet_Change(ByVal Target As Range)  '入力規則設定　1階層目の範囲が変化した場合にgetntを実行　：　チェンジイベント発生時実行

  Worksheets("main2").Activate

     '3階層の入力規則（名前の利用の処理：2階層目への処理のトリガー）/////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("B4")) Is Nothing Then  '1階層目の欄が変化した場合の処理

          Else

         Call getit1

     End If

     '3階層の入力規則（範囲の利用の処理：3階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("C4")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call getit2

     End If

   '3階層の入力規則（範囲の利用の処理：2階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("B14:B24")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call pgetit1

     End If

  '3階層の入力規則（範囲の利用の処理：3階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("C14:C24")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call pgetit2

     End If

  End Sub

入力規則_3階層入力（固定枠）（ダウンロード）
※（表形式入力のデータも含みます）

3階層入力規則の例（表形式）

この例は、上記と同じ参照元データを元に、表形式で選択入力するようにしたものです。
固定枠と異なる点は、
px = ActiveCell.Row 'アクテイブセルの座標ｘ
py = ActiveCell.Column 'アクテイブセルの座標ｙ
と言うActiveCellプロパティで、現時点での入力枠の座標を取得して、次の入力規則の設定の処理をしていきます。

●ここでの基本的モジュール
（標準モジュール）
getnt4（1階層目）
pgetit1（2階層目）
pgetit2（3階層目）
clr11（解除）
（シートモジュール）
Private Sub Worksheet_Change(ByVal Target As Range)
　　　：

3階層入力規則の1階層目（表形式）

  Sub getnt4()    '■■■3階層の入力規則　1階層目■■■（表入力）

  Dim lrows As Integer
  Dim items1 As String
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet

  Set ws1 = Worksheets("main2")
  Set ws2 = Worksheets("pdata2")

  '1階層目のデータ取得(文字列化）/////////////////////////////////////////////////

  '1列目の最終行取得
  lrows = ws2.Cells(Rows.Count, 1).End(xlUp).Row

  'アイテムの文字列化（コンマ区切り）
  For k = 1 To lrows

    If ws2.Cells(k + 1, 1) <> "" Then  '空白ではない項目をコンマを挟んで文字列に蓄積

       items1 = items1 + "," + ws2.Cells(k + 1, 1)

    End If

  Next

  items1 = Right(items1, Len(items1) - 1)    '始めのコンマの削除

  'ws1.Cells(10, 5) = items1

      '入力規則1階層目の設定/////////////////////////////////////////////////////
      With ws1.Range("B14:B24").Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items1
      End With

  End Sub

3階層入力規則の2階層目（表形式）

  Sub pgetit1()  '■■■3階層の入力規則　2階層目■■■（表入力）

  Dim rng As Range
  Dim tchr1 As String             '1階層目の文字列収容
  Dim items2 As String            '2階層目の文字列収容(カンマ区切り）
  Dim items3 As String            '3階層目の文字列収容(カンマ区切り）
  Dim itrowe As Integer           '2階層目の最終行
  Dim fnrowt As Integer           '1階層目の行（検索文字と合致）
  Dim fnrowe As Integer           '合致した行から下へ検索した場合の空白でない最初の行（1列目：pdata2）
  Dim ws1 As Worksheet            'ワークシート
  Dim ws2 As Worksheet            'ワークシート

  Set ws1 = Worksheets("main2")   'ワークシート名の収容
  Set ws2 = Worksheets("pdata2")  'ワークシート名の収容

      px = ActiveCell.Row             'アクテイブセルの座標ｘ
      py = ActiveCell.Column          'アクテイブセルの座標ｙ

   ws1.Range(ws1.Cells(px, 3), ws1.Cells(px, 4)) = ""      '1階層目が変化したら2階層、3階層の欄を初期化する

  '1階層目のデータ取得
  tchr1 = ws1.Cells(px, 2)

  '1階層目の最初の行数
   Set rng = ws2.Columns(1).Find(What:=tchr1, LookAt:=xlWhole)

  '2階層目の最終行
  itrowe = ws2.Cells(Rows.Count, 2).End(xlUp).Row

  '1階層目の行（検索文字と合致）
  fnrowt = rng.Row


  '1階層目に対応する2階層目の範囲を取得（最初の行、最後の行）***************
  For k = fnrowt + 1 To itrowe

   If ws2.Cells(k, 1) <> "" Then

         fnrowe = k - 1
         Exit For

       Else

         fnrowe = itrowe

   End If

  Next
  '*************************************************************************

  'fnrowt        '1階層目の範囲（最初の行）
  'fnrowe        '1階層目の範囲（最後の行）
  'itrowe        '2階層目の最下行

  '2階層目のアイテムを文字列化（カンマ区切り）******************************

  For k = fnrowt To fnrowe

     items2 = items2 + "," + ws2.Cells(k, 2)

  Next

  items2 = Right(items2, Len(items2) - 1)    '最初のカンマを削除

  '*************************************************************************

      With ws1.Range(ws1.Cells(px, 4), ws1.Cells(px, 4)).Validation       '3階層目の入力規則削除
          .Delete
      End With

   '入力規則2階層目の設定/////////////////////////////////////////////////////
      With ws1.Range(ws1.Cells(px, 3), ws1.Cells(px, 3)).Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items2
      End With

  End Sub

3階層入力規則の3階層目（表形式）

  Sub pgetit2()  '■■■3階層の入力規則　3階層目■■■（表入力）

  Dim rng As Range                '2階層目の文字findの検索結果収容(pdata2)
  Dim tchr2 As String             '2階層目の文字収容
  Dim fnrowt2 As Integer          '2階層目の行（検索文字と合致)の収容
  Dim fnclmt2 As Integer          '検索文字と合致した行の終端（カラム数）
  Dim items3 As String            '3階層目の文字列収容(カンマ区切り）用

  Dim ws1 As Worksheet            'ワークシート
  Dim ws2 As Worksheet            'ワークシート

  Set ws1 = Worksheets("main2")   'ワークシート名の収容
  Set ws2 = Worksheets("pdata2")  'ワークシート名の収容

  ws1.Range("d4") = ""

      px = ActiveCell.Row             'アクテイブセルの座標ｘ
      py = ActiveCell.Column          'アクテイブセルの座標ｙ

  '2階層目のデータ取得
   tchr2 = ws1.Cells(px, 3)

  '2階層目の行数
   Set rng = ws2.Columns(2).Find(What:=tchr2, LookAt:=xlWhole)

  '2階層目の行（検索文字と合致）3階層目の行数も同じ
   fnrowt2 = rng.Row

  '検索文字と合致した行の終端（カラム数）
   fnclmt2 = ws2.Cells(fnrowt2, Columns.Count).End(xlToLeft).Column

  '3階層目のアイテムを文字列化（カンマ区切り）******************************

  For k = 3 To fnclmt2

     items3 = items3 + "," + ws2.Cells(fnrowt2, k)

  Next

  If Len(items3) - 1 > 0 Then

      items3 = Right(items3, Len(items3) - 1)    '最初のカンマを削除

  'ws1.Cells(10, 3) = items3

   '入力規則3階層目の設定/////////////////////////////////////////////////////
      With ws1.Range(ws1.Cells(px, 4), ws1.Cells(px, 4)).Validation
          .Delete
          .Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=items3
      End With

  End If

  End Sub

入力規則の解除

  Sub clr11()  '入力規則_3階層のリスト選択の設定の解除（表入力）

      Worksheets("main2").Range("B14:D24") = ""

      With Worksheets("main2").Range("B14:D24").Validation

          .Delete

      End With

  End Sub

選択肢の変化の検出（シートモジュール）

  Private Sub Worksheet_Change(ByVal Target As Range)  '入力規則設定　1階層目の範囲が変化した場合にgetntを実行　：　チェンジイベント発生時実行

  Worksheets("main2").Activate

     '3階層の入力規則（名前の利用の処理：2階層目への処理のトリガー）/////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("B4")) Is Nothing Then  '1階層目の欄が変化した場合の処理

          Else

         Call getit1

     End If

     '3階層の入力規則（範囲の利用の処理：3階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("C4")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call getit2

     End If

   '3階層の入力規則（範囲の利用の処理：2階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("B14:B24")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call pgetit1

     End If

  '3階層の入力規則（範囲の利用の処理：3階層目への処理のトリガー）////////////////////////////////////////
     If Intersect(Target, Worksheets("main2").Range("C14:C24")) Is Nothing Then  '2階層目の欄が変化した場合の処理

          Else

         Call pgetit2

     End If

  End Sub

入力規則_3階層入力（固定枠）（ダウンロード）
※（固定枠入力のデータも含みます）

入力規則その3（総まとめ）
以上のTIPSをまとめたファイルです。お時間の無い方におまとめ編です。
入力制限や2階層選択入力について実際に動かして試せます。

入力規則の3（総まとめ）ダウンロード