【Excel】 数階層のドロップダウンリストを設定

質問

Excel2007を使っています。

B3を分類の「A、B、C」のドロップダウンリストから選択します。
※別表のG3:G16を元にしますが、「A、A、A、A、A、A、B、B、B・・・」とならないようにしたいです。
また、B3に「A」を選んだ場合、C3に「DDD、EEE、FFF」のドロップダウンが表示され、
C3に「DDD」を選んだ場合、D3に「1001、1002」のドロップダウンが表示され、
いずれかを選択します。

このような入力規制を設定したいのですが、
B3、C3、D3をどのように設定したらよいのか教えて下さい。

宜しくお願いいたします。

回答No.9

cj_mover · ベストアンサー

＃１、２、４、６、７、８、ｃｊです。
＃８補足欄へのレスです。

言われてみれば、別シートにある方が自然ですよね。
対応が遅れた感はあります。

変更点を■■で示しました。

入力規則設置するシートのシートモジュール、
まるまる差し替え、です。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Option Explicit

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Const イベント範囲 As String = "C9:D20"　　'　　下位の入力規則を変更するイベント処理対象範囲の参照（２列）■要指定
Const マスタシート名 As String = "Sheet1"　　'　　マスタテーブルのシート名■■要指定
Const マスタ左上 As String = "V9"　　'　　マスタテーブル範囲の参照（データ部左上の単セル）■要指定
　　　　　　　　' ' ユーザー設定　↑
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
　　　　　　　　' ' 固定　↓
Const SHOGE As String = "分類"
Const SCOMMA As String = ","
　　　　　　　　　　　　' ' 参照設定する場合◆ : Microsoft Scripting Runtime
Private oDict(0 To 2) As Object　　'　　As Scripting.Dictionary ' ◆

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub 初期設定()　　'　　マスタ変更時の更新も
　　Call SetValid
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub SetValid(Optional ByVal Target As Range)
　　Dim sKey As String
　　Dim sList As String
　　Dim nFldPos As Long
　　Dim nOffset As Long
　　Dim i As Long

　　If Target Is Nothing Then
　　　　Set Target = Range(イベント範囲)
　　　　sKey = SHOGE　　'　　"分類"
'　　　　nFldPos = 0&　:　nOffset = 0&
　　　　Range(イベント範囲)(1).Select　' ' ●●
　　Else
　　　　sKey = Target.Value
　　　　nFldPos = Target.Column - Range(イベント範囲).Column + 1
　　　　nOffset = 1&
　　End If

　　Application.EnableEvents = False
　　On Error GoTo Exit_

　　If oDict(0) Is Nothing Then Call SetDict

　　With Target
　　　　For i = nFldPos To 2
　　　　　　nOffset = nOffset + 1&
　　　　　　sList = oDict(i)(sKey)　 '　　",A,B,C"　　",DDD,EEE,FFF"　　",1001,1002"
If sList = "" Then　' ' ●
MsgBox Split("分類： 品名：")(i) & sKey & "　マッチしません"　' ' ●
Application.EnableEvents = True　' ' ●
Exit Sub　' ' ●
End If　' ' ●
　　　　　　With .Columns(nOffset)
　　　　　　　　With .Validation
　　　　　　　　　　.Delete
　　　　　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList
'　　　　　　　　　　.IgnoreBlank = True
'　　　　　　　　　　.InCellDropdown = True
　　　　　　　　End With
　　　　　　　　sKey = Split(sList, SCOMMA)(1)　　'　　"A"　　"DDD"　　"1001"
　　　　　　　　.Value = sKey
　　　　　　End With
　　　　Next i
　　End With

Exit_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbExclamation
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub SetDict()
　　Dim mtxT()
　　Dim i As Long

'　　With Range(マスタ左上)　　'　　（１／２択）マスタが同一シート上にある場合■■要指定
　　With Sheets(マスタシート名).Range(マスタ左上)　　'　　（２／２択）マスタシート名を指定する場合■■要指定
　　　　mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value
　　End With

　　For i = 0 To 2
　　　　Set oDict(i) = CreateObject("Scripting.Dictionary")
'　　　　Set oDict(i) = New Scripting.Dictionary ' ◆
　　Next i

　　For i = 1 To UBound(mtxT)
　　　　If Not oDict(1).Exists(mtxT(i, 1)) Then
　　　　　　oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)
　　　　　　oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲
　　　　ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then
　　　　　　oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲
　　　　End If
　　　　oDict(2)(CStr(mtxT(i, 2))) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3) ' ' ▲
　　Next i
　　Erase mtxT()

'' ' ツリー確認用コード
'　　Dim k1, k2, s2, v0, v1
'　　Debug.Print SHOGE, oDict(0)(SHOGE)
'　　k1 = oDict(1).Keys
'　　For Each v0 In k1
'　　　　Debug.Print , v0, oDict(1)(v0)
'　　　　k2 = Split(oDict(1)(v0), SCOMMA)
'　　　　For Each v1 In k2
'　　　　　　If v1 <> "" Then Debug.Print , , v1, oDict(2)(v1)
'　　　　Next
'　　Next
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　If Target.Value = "" Then Exit Sub
　　If Intersect(Range(イベント範囲).Resize(, 2), Target) Is Nothing Then Exit Sub

　　Call SetValid(Target)
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_Deactivate()
　　Erase oDict()
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

お礼

この度は、いろいろと希望に対応下さいましたおかげで、
大変使いやすい表が出来上がりました。

また、カスタマイズしたい部分はありますが、
今回とは別に質問を上げたいと思います。

本当にお世話になりました。

回答No.8

cj_mover

＃１、２、４、６、７、ｃｊです。
＃７補足欄へのレスです。

> こちらを実行して、リストから選択いたしますと、
> 「1004アプリケーション定義またはオブジェクト定義のエラーです」となります。
> (ただ、アラートが表示されますが処理は正常に行われているようなのです)。

エラーが起こるとすれば、正常終了ではなく
下位の入力規則が設定される前に終了してしまう筈なのですが。
、、という前提で対策を考えてみました。

> ...マスターテーブルの値ですが、...
> 実値は、分類に全角文字で学校の名前(○○小学校)などが、
> 品名も全角文字で商品の名前(○○学生服)などが、
> 品番は、全角文字と半角英数字(GSW100EW)などが使われています。
> このあたりの固定をしないといけないのでしょうか。

文字列であれば、まず問題ないです。
特に説明しませんでしたが、入力規則のリスト指定がカンマ区切りですので、
分類、品名、品番、に指定する各セル値に","を使うことはエラーの原因になります。
また、数値や日付値を指定してある場合もエラーに繋がります。
以上の点は意識はしていたものの分類、品名、品番、という項目名からして
対策の必要ないと考えたものです。
でもまぁ数値については、対応しないのも変でしたね。バグ、と呼べなくもない。
セル値が数値でもエラーにならないようにしました。 ' ' ▲

自分なりに想定の幅を拡げ、十分な対策を施したつもりではいますが、
私の迂闊は珍しくもないので、もし漏れがある場合に
原因を特定する為だけの一時的な（不要になったら削除する）記述を
５行 ' ●　マークを付けて示しました。
マクロ側でDictionaryオブジェクトに登録したKeyと
セル値とのマッチングがうまく行ってない場合にメッセージを表示しますので
表示されたなら、内容を確認してみてください。それによって対処します。
暫く様子みてみましょう。

> あと、処理後、C9のセルに戻りたいのですが
> Range("C9").Select を どこに入れたら良いでしょうか。

追加した記述を　' ' ●●　マークを付けて示しました。
処理後、というのが微妙ですが、初期設定後、という解釈です。

> 何度も申し訳ございません。
いいえ。お気になさらず。お互い様です。
こちらも即応レスはできませんが、何とか解決させたいです。

文字数制限に掛かることもあって、ご面倒でしょうが
２つのプロシージャだけ＃７について差し換えでお願いします。

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub SetValid(Optional ByVal Target As Range)
　　Dim sKey As String
　　Dim sList As String
　　Dim nFldPos As Long
　　Dim nOffset As Long
　　Dim i As Long

　　If Target Is Nothing Then
　　　　Set Target = Range(イベント範囲)
　　　　sKey = SHOGE　　'　　"分類"
'　　　　nFldPos = 0&　:　nOffset = 0&
　　　　Range(イベント範囲)(1).Select　' ' ●●
　　Else
　　　　sKey = Target.Value
　　　　nFldPos = Target.Column - Range(イベント範囲).Column + 1
　　　　nOffset = 1&
　　End If

　　Application.EnableEvents = False
　　On Error GoTo Exit_

　　If oDict(0) Is Nothing Then Call SetDict

　　With Target
　　　　For i = nFldPos To 2
　　　　　　nOffset = nOffset + 1&
　　　　　　sList = oDict(i)(sKey)　 '　　",A,B,C"　　",DDD,EEE,FFF"　　",1001,1002"
If sList = "" Then　' ' ●
MsgBox Split("分類： 品名：")(i) & sKey & "　マッチしません"　' ' ●
Application.EnableEvents = True　' ' ●
Exit Sub　' ' ●
End If　' ' ●
　　　　　　With .Columns(nOffset)
　　　　　　　　With .Validation
　　　　　　　　　　.Delete
　　　　　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList
'　　　　　　　　　　.IgnoreBlank = True
'　　　　　　　　　　.InCellDropdown = True
　　　　　　　　End With
　　　　　　　　sKey = Split(sList, SCOMMA)(1)　　'　　"A"　　"DDD"　　"1001"
　　　　　　　　.Value = sKey
　　　　　　End With
　　　　Next i
　　End With

Exit_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbExclamation
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub SetDict()
　　Dim mtxT()
　　Dim i As Long

　　With Range(マスタ左上)
　　　　mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value
　　End With

　　For i = 0 To 2
　　　　Set oDict(i) = CreateObject("Scripting.Dictionary")
'　　　　Set oDict(i) = New Scripting.Dictionary ' ◆
　　Next i

　　For i = 1 To UBound(mtxT)
　　　　If Not oDict(1).Exists(mtxT(i, 1)) Then
　　　　　　oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)
　　　　　　oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲
　　　　ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then
　　　　　　oDict(1)(CStr(mtxT(i, 1))) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2) ' ' ▲
　　　　End If
　　　　oDict(2)(CStr(mtxT(i, 2))) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3) ' ' ▲
　　Next i
　　Erase mtxT()

'' ' ツリー確認用コード
'　　Dim k1, k2, s2, v0, v1
'　　Debug.Print SHOGE, oDict(0)(SHOGE)
'　　k1 = oDict(1).Keys
'　　For Each v0 In k1
'　　　　Debug.Print , v0, oDict(1)(v0)
'　　　　k2 = Split(oDict(1)(v0), SCOMMA)
'　　　　For Each v1 In k2
'　　　　　　Debug.Print , , v1, oDict(2)(v1)
'　　　　Next
'　　Next
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

補足

毎回、迅速かつ正確なご回答に感謝申し上げます。

上記も大変上手く行きました。

ただ、大変申し訳ないのですが、
マスターテーブルの部分を別のシートに設置した場合は、
どうしたらよいでしょうか。

Const マスタ左上 As String = "Sheet1!V9"

としても、ダメでした。

最後にこの部分を教えて頂ければ幸いです。

宜しくお願いいたします。

回答No.7

cj_mover

こんにちは。＃１、２、４、６、ｃｊです。
＃６で触れていた
> ...セル範囲の参照を容易に変更できる内容に書き換え...
やってみました。
その影響で処理の効率が落ちる面もあるので、その分、
他の部分を見直して補い、トータルでは、前より動作が軽くなっています。

先頭の２カ所だけ、セル範囲を指定すれば、
テーブルの位置を変更した場合にも容易に対応できます。

動作仕様はこれまで提示したものとまったく同じです。
まるまる差し替えで使ってください。

それでは、また。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Option Explicit
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Const イベント範囲 As String = "C9:D20"　　'　　下位の入力規則を変更するイベント処理対象範囲の参照（２列）■要指定
Const マスタ左上 As String = "V9"　　'　　マスタテーブル範囲の参照（データ部左上の単セル）■要指定
　　　　　　　　' ' ユーザー設定　↑
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
　　　　　　　　' ' 固定　↓
Const SHOGE As String = "分類"
Const SCOMMA As String = ","
　　　　　　　　　　　　' ' 参照設定する場合◆ : Microsoft Scripting Runtime
Private oDict(0 To 2) As Object　　'　　As Scripting.Dictionary ' ◆
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Sub 初期設定()
　　Call SetValid
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub SetValid(Optional ByVal Target As Range)
　　Dim sKey As String
　　Dim sList As String
　　Dim nFldPos As Long
　　Dim nOffset As Long
　　Dim i As Long

　　If Target Is Nothing Then
　　　　Set Target = Range(イベント範囲)
　　　　sKey = SHOGE　　'　　"分類"
'　　　　nFldPos = 0&　:　nOffset = 0&
　　Else
　　　　sKey = Target.Value
　　　　nFldPos = Target.Column - Range(イベント範囲).Column + 1
　　　　nOffset = 1&
　　End If

　　Application.EnableEvents = False
　　On Error GoTo Exit_

　　If oDict(0) Is Nothing Then Call SetDict

　　With Target
　　　　For i = nFldPos To 2
　　　　　　nOffset = nOffset + 1&
　　　　　　sList = oDict(i)(sKey)　 '　　",A,B,C"　　",DDD,EEE,FFF"　　",1001,1002"
　　　　　　With .Columns(nOffset)
　　　　　　　　With .Validation
　　　　　　　　　　.Delete
　　　　　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=sList
'　　　　　　　　　　.IgnoreBlank = True
'　　　　　　　　　　.InCellDropdown = True
　　　　　　　　End With
　　　　　　　　sKey = Split(sList, SCOMMA)(1)　　'　　"A"　　"DDD"　　"1001"
　　　　　　　　.Value = sKey
　　　　　　End With
　　　　Next i
　　End With

Exit_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbExclamation
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub SetDict()
　　Dim mtxT()
　　Dim i As Long

　　With Range(マスタ左上)
　　　　mtxT = .Resize(.End(xlDown).Row - .Row + 1, 3).Value
　　End With

　　For i = 0 To 2
　　　　Set oDict(i) = CreateObject("Scripting.Dictionary")
'　　　　Set oDict(i) = New Scripting.Dictionary ' ◆
　　Next i

　　For i = 1 To UBound(mtxT)
　　　　If Not oDict(1).Exists(mtxT(i, 1)) Then
　　　　　　oDict(0)(SHOGE) = oDict(0)(SHOGE) & SCOMMA & mtxT(i, 1)
　　　　　　oDict(1)(mtxT(i, 1)) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2)
　　　　ElseIf Not oDict(2).Exists(mtxT(i, 2)) Then
　　　　　　oDict(1)(mtxT(i, 1)) = oDict(1)(mtxT(i, 1)) & SCOMMA & mtxT(i, 2)
　　　　End If
　　　　oDict(2)(mtxT(i, 2)) = oDict(2)(mtxT(i, 2)) & SCOMMA & mtxT(i, 3)
　　Next i
　　Erase mtxT()

'' ' ＜　ツリー確認用
'　　Dim k1, k2, s2, v0, v1
'　　Debug.Print SHOGE, oDict(0)(SHOGE)
'　　k1 = oDict(1).Keys 'Split(SHOGE, SCOMMA)
'　　For Each v0 In k1
'　　　　Debug.Print , v0, oDict(1)(v0)
'　　　　k2 = Split(oDict(1)(v0), SCOMMA)
'　　　　For Each v1 In k2
'　　　　　　Debug.Print , , v1, oDict(2)(v1)
'　　　　Next
'　　Next
'' ' ＞
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　If Target.Value = "" Then Exit Sub
　　If Intersect(Range(イベント範囲).Resize(, 2), Target) Is Nothing Then Exit Sub

　　Call SetValid(Target)
End Sub
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Worksheet_Deactivate()
　　Erase oDict()
End Sub
' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

補足

改訂頂きましてありがとうございます。

＃６の方でも、上手く行きました。

確かに、イベント処理対象範囲が変わる可能性が有り、
こちらの改訂版を使えればと思ったのですが、
こちらを実行して、リストから選択いたしますと、
「1004アプリケーション定義またはオブジェクト定義のエラーです」となります。
(ただ、アラートが表示されますが処理は正常に行われているようなのです)。

なお、マスターテーブルの値ですが、質問の際
便宜上、A、DDDD、1001、などといたしましたが、
実値は、分類に全角文字で学校の名前(○○小学校)などが、
品名も全角文字で商品の名前(○○学生服)などが、
品番は、全角文字と半角英数字(GSW100EW)などが使われています。
このあたりの固定をしないといけないのでしょうか。

あと、処理後、C9のセルに戻りたいのですが
Range("C9").Select を どこに入れたら良いでしょうか。

何度も申し訳ございません。

回答No.6

cj_mover

＃１、２、４、ｃｊです。
＃４補足欄へのレスです。

> B3の部分が C9に、
> G3の部分が V9に移動しました。

都合８カ所、セル範囲の参照を直す必要があります。
　変更前の記述を先頭に「'」を付けてコメントブロック、
　変更後の記述を直下の行に、
示しました。
シートモジュールごと、まるまる、差し替えれば、
移動後の各テーブルに対応しています。

今後も変更の可能性があるならば、
セル範囲の参照を容易に変更できる内容に書き換えた方が
いいのかな？と思っています。
一方で、"マスター"を移動する機会は殆どないだろう、という
都合のいい予想もあるので、今回は、
対症療法的な修正だけにとどめます。
（あまりレスが増えても混乱してしまうでしょうし）
もし、今後も移動することが想定されるならば、
少しでもメンテし易いものに書き直そうと思います。
その場合は、改めて、別件の質問として来週ぐらいにでも
あげてみてください。
設計の異なるアプローチや色んな仕様を試しているうちに
手元では、１５バージョン程になってしまい、
混乱している上に、今、私の頭のパフォーマンスが落ちています。
少し時間を空けて欲しいのは、そういう理由です。
やる気はありますので（笑）

では、修正済のコードを。

Option Explicit

Private oDict As Object
' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　If Target.Value = "" Then Exit Sub
'　　If Target.Row < 3 Or Target.Row > 14 Then Exit Sub
　　If Target.Row < 9 Or Target.Row > 20 Then Exit Sub
'　　If Target.Column > 3 Or Target.Column = 1 Then Exit Sub
　　If Target.Column > 4 Or Target.Column < 3 Then Exit Sub

　　Application.EnableEvents = False

　　On Error GoTo Exit_
　　Call UniqValid品名品番(Target)

Exit_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbExclamation
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid品名品番(ByVal Target As Range)
　　Dim mtxSrc, arrList
　　Dim sParent As String
　　Dim i As Long
　　Dim flg As Boolean

'　　mtxSrc = Range(Cells(3, Target.Column + 5), Cells(3, Target.Column + 6).End(xlDown)).Value
　　mtxSrc = Range(Cells(9, Target.Column + 19), Cells(9, Target.Column + 20).End(xlDown)).Value
　　sParent = Target.Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　For i = 1 To UBound(mtxSrc)
　　　　If mtxSrc(i, 1) = sParent Then
　　　　　　oDict(mtxSrc(i, 2)) = Empty
　　　　　　flg = True
　　　　ElseIf flg Then
　　　　　　Exit For
　　　　End If
　　Next i

　　arrList = oDict.keys

　　With Target.Offset(, 1)
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

'　　If Target.Column = 2 Then Call UniqValid品名品番(Target.Offset(, 1))
　　If Target.Column = 3 Then Call UniqValid品名品番(Target.Offset(, 1))

　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid分類_開始()
　　Dim vSrc, v, arrList

'　　vSrc = Range("G3", Range("G3").End(xlDown)).Value
　　vSrc = Range("V9", Range("V9").End(xlDown)).Value
　　If UBound(vSrc) < 1 Then Exit Sub

　　Set oDict = CreateObject("Scripting.Dictionary")

　　For Each v In vSrc
　　　　oDict(v) = Empty
　　Next
　　arrList = oDict.keys

　　Application.EnableEvents = False

'　　With Range("B3")
　　With Range("C9")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = arrList(0)
　　End With

'　　Call UniqValid品名品番(Range("B3"))
　　Call UniqValid品名品番(Range("C9"))

'　　Range("B3:E3").Copy Destination:=Range("B4:B14")
　　Range("C9:F9").Copy Destination:=Range("C10:C20")

　　Application.EnableEvents = True
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

回答No.5

tom04

No.3です！
たびたびごめんなさい。

前回の投稿でSheet２のA～C列の名前定義はしなくても大丈夫のようです。
すなわち前回アップした画像では
Sheet2のA1～C1セルのアンダースコア-は必要なく、
そのまま「分類」名を入力しておけば
対応できそうです。

Sheet1のB列の入力規則の「元の値」の欄に
=Sheet2!A$1:C$1
という数式を入れるだけで対応できます。

ただし、D列以降はやはり名前定義が必要みたいですね！
実際にExcel2007でOFFSET関数でやってみると
やはり別Sheetは参照できないようですので、前回同様名前定義しなくてはならないようです。

※Excel2010以降であれば名前定義は必要なく、表さえ作成しておけば
元の値の欄に数式を入れるだけで対応できます。

ちゃんと検証せずに投稿してごめんなさいね。m（_ _）m

お礼

おかげさまで、
いろいろな方法が確認できました。
今回は、VBAであっさりとできてしまい
(VBAを組んで下さった方は大変だったはず)
こちらを使わせて頂くこととしました。

ありがとうございました。

回答No.4

cj_mover

＃１、２、ｃｊです。
すみません。＃２で、一部ミス（慌てて転載ミス）があって
機能しないものを掲載していました。
Sub UniqValid分類_開始()　だけ、まるまる差し替えてくださいませ。
失礼しました。

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid分類_開始()
　　Dim vSrc, v, arrList

　　vSrc = Range("G3", Range("G3").End(xlDown)).Value
　　If UBound(vSrc) < 1 Then Exit Sub

　　Set oDict = CreateObject("Scripting.Dictionary")

　　For Each v In vSrc
　　　　oDict(v) = Empty
　　Next
　　arrList = oDict.keys

　　Application.EnableEvents = False

　　With Range("B3")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = arrList(0)
　　End With

　　Call UniqValid品名品番(Range("B3"))

　　Range("B3:E3").Copy Destination:=Range("B4:B14")

　　Application.EnableEvents = True
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

補足

早速補足下さいましてありがとうございます。
差し替えまして上手く行きました。

もう一点だけ教えて下さい。

実際の票に配置したときに、
B3の部分が C9に、
G3の部分が V9に移動しました。

このとき、Sub UniqValid分類_開始() の
Rangeで指定された部分を該当セルに書き換え
以下の通りにしました。

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid分類_開始()

Dim vSrc, v, arrList

vSrc = Range("V9", Range("V9").End(xlDown)).Value
If UBound(vSrc) < 1 Then Exit Sub

Set oDict = CreateObject("Scripting.Dictionary")

For Each v In vSrc
oDict(v) = Empty
Next
arrList = oDict.keys

Application.EnableEvents = False

With Range("C9")
With .Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=Join(arrList, ",")
End With
.Value = arrList(0)
End With

Call UniqValid品名品番(Range("C9"))

Range("C9:F9").Copy Destination:=Range("C10:C20")

Application.EnableEvents = True
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

しかし、これを実行すると、「400」とだけかかれたアラートが出ます。
こんな、単純な対応ではダメでしょうか・・・

この部分だけ、今一度お願いいたします。

回答No.3

tom04

こんばんは！
超ベタな方法ですが・・・

やり方だけを↓の画像で説明します。（画像が小さかったら拡大してください。）
画像の上側をSheet2・下の右側をSheet3とし、下側左のSheet1にリスト表示させるとします。

表の作成と名前定義に一手間、いや二手間以上しっかり手間をかけます。

画像では頭の分類がアルファベットになっていますね！（実際はアルファベットではないと思いますが）
名前定義する際に数字およびアルファベットの中で使えないものがありますので、
あらかじめアンダースコアー（_）を付けたデータで表を作成しておきます。
（分類名が数値・アルファベット以外であれば頭のアンダースコアーは必要ありません。）

（1）Sheet2のA1～C1セルを範囲指定　→　名前ボックスに　仮に　分類　と入力　→　Enter
これでSheet2のA1～C1セルが「分類」という名前定義されました。

（2）Sheet2のA1以降を範囲指定　→　数式　→　名前の管理　→　選択範囲から作成　→　上端行　→　OK
B1以降を範囲指定　→　・・・中略・・・（同様に）　→　OK
この操作をSheet2のすべての列で行います。
これでSheet2の色付きセルで名前定義されます。

（3）Sheet3に分類・品名・品番のすべてをアンダースコアーでつないだデータの価格を作成します。

以上の準備ができれば後は簡単です。

Sheet1のB3以降を範囲指定　→　データ　→　データの入力規則　→　リスト　→　元の値の欄に
=分類
としてOK

C3以降を範囲指定　→　（同上）・・・中略・・・　→　元の値の欄に
=INDIRECT(B3)
としてOK

D3以降を範囲指定　→　（同上）・・・中略・・・　→　元の値の欄に
=INDIRECT(B3&"_"&C3)
としてOK
これで入力規則の設定は完了です。

最後にE3セルに
=IF(COUNTBLANK(B3:D3),"",IFERROR(VLOOKUP(B3&"_"&C3&"_"&D3,Sheet3!A:B,2,0),"該当データなし"))
という数式を入れオートフィルで下へコピーしておきます。

これで何とかご希望に近い形にならないでしょうか？

※　Exce2010以降であればリストの元の値の欄に数式で別Sheetを指定できますが、
Excel2007ではおそらくダメだったと思います。
そのためこまめに名前定義してみました。

他に良い方法があればごめんなさいね。m(_ _)m

回答No.2

cj_mover

＃１、ｃｊです。
＃！補足欄へのレスです。

今あまり時間取れないので取り急ぎ。
扱いは全く同じです。まるごと差し換えで。
プロシージャ、ひとつ減らしました。

それと、ひとつだけ注意点。
'子'リストの自動変更は、B3:C14の範囲内で
単一のセルの値変更があった場合にのみ機能します。
例えば、B3:C14の範囲内の複数セル範囲へ貼り付けした場合などは
'子'リストの自動変更は行われない仕様です。
この点の仕様変更が必要なら再レスします。
ただ、次は明日になると思います（今から送別会で遅くなるので）。

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit

Private oDict As Object

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　If Target.Value = "" Then Exit Sub
　　If Target.Row < 3 Or Target.Row > 14 Then Exit Sub
　　If Target.Column > 3 Or Target.Column = 1 Then Exit Sub

　　Application.EnableEvents = False

　　On Error GoTo Exit_
　　Call UniqValid品名品番(Target)

Exit_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbCritical
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid品名品番(ByVal Target As Range)
　　Dim mtxSrc, arrList
　　Dim sParent As String
　　Dim i As Long
　　Dim flg As Boolean

　　mtxSrc = Range(Cells(3, Target.Column + 5), Cells(3, Target.Column + 6).End(xlDown)).Value
　　sParent = Target.Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　For i = 1 To UBound(mtxSrc)
　　　　If mtxSrc(i, 1) = sParent Then
　　　　　　oDict(mtxSrc(i, 2)) = Empty
　　　　　　flg = True
　　　　ElseIf flg Then
　　　　　　Exit For
　　　　End If
　　Next i

　　arrList = oDict.keys

　　With Target.Offset(, 1)
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

　　If Target.Column = 2 Then Call UniqValid品名品番(Target.Offset(, 1))
　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqValid分類_開始()
　　Dim vSrc, v, arrList

　　vSrc = Range("G3", Range("G3").End(xlDown)).Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　If UBound(vSrc) < 1 Then
　　　　oDict.Add v, Empty
　　Else
　　　　For Each v In vSrc
　　　　　　oDict(v) = Empty
　　　　Next
　　End If
　　arrList = oDict.keys

　　Application.EnableEvents = False

　　With Range("B3")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

　　Call UniqValid品名((arrList(0)))

　　Range("B3:E3").Copy Destination:=Range("B4:B14")

　　Application.EnableEvents = True

　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

回答No.1

cj_mover

こんにちは。

ＶＢＡによる対応になります。

Sub UniqVal分類_開始()　を実行することで初期設定されます。
[分類]を追加｜削除した場合は初期設定し直す必要があります。

後は、B3,C3が変更される度に下位のリストを自動的に変更します。

[分類]＞[品名]＞[品番]
'親'側が変更されると、'子'（'孫'）のリストも変更され、
それぞれ、リストの最上位にある値を仮設定します。

Worksheet_Change イベントを既に使っている場合は
適切な形で組み込み統合する必要があります。
（手に余るようでしたら、既存のコードをご提示の上、ご相談ください）
当該シートのシートモジュールに、
以下、全文、過不足なく、貼付け、Sub UniqVal分類_開始()を実行、保存。

Option Explicit

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private oDict As Object

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Private Sub Worksheet_Change(ByVal Target As Range)
　　If Target.Count > 1 Then Exit Sub
　　If Target.Value = "" Then Exit Sub
　　If Target.Row <> 3 Then Exit Sub
'　　If Target.Column > 3 Or Target.Column = 1 Then Exit Sub
　　If Not Target.Column Like "[23]" Then Exit Sub

　　Application.EnableEvents = False

　　On Error GoTo ErrOut_
　　Select Case Target.Column
　　Case 2
　　　　Call UniqVal品名(Target.Value)
　　Case 3
　　　　Call UniqVal品番(Target.Value)
　　End Select

ErrOut_:
　　Application.EnableEvents = True
　　If Err Then MsgBox Err & Err.Description, vbCritical
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqVal品番(sParent As String)
　　Dim mtxSrc, arrList
　　Dim i As Long
　　Dim flg As Boolean

　　mtxSrc = Range("H3", Range("I3").End(xlDown)).Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　For i = 1 To UBound(mtxSrc)
　　　　If mtxSrc(i, 1) = sParent Then
　　　　　　oDict(mtxSrc(i, 2)) = Empty
　　　　　　flg = True
　　　　ElseIf flg Then
　　　　　　Exit For
　　　　End If
　　Next i

　　arrList = oDict.keys

　　With Range("D3")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqVal品名(sParent As String)
　　Dim mtxSrc, arrList
　　Dim i As Long
　　Dim flg As Boolean

　　mtxSrc = Range("G3", Range("H3").End(xlDown)).Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　For i = 1 To UBound(mtxSrc)
　　　　If mtxSrc(i, 1) = sParent Then
　　　　　　oDict(mtxSrc(i, 2)) = Empty
　　　　　　flg = True
　　　　ElseIf flg Then
　　　　　　Exit For
　　　　End If
　　Next i

　　arrList = oDict.keys

　　With Range("C3")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

　　Call UniqVal品番((arrList(0)))

　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Sub UniqVal分類_開始()
　　Dim vSrc, v, arrList

　　vSrc = Range("G3", Range("G3").End(xlDown)).Value

　　On Error GoTo CrDict_
　　oDict.RemoveAll
　　On Error GoTo 0

　　If UBound(vSrc) < 1 Then
　　　　oDict.Add v, Empty
　　Else
　　　　For Each v In vSrc
　　　　　　oDict(v) = Empty
　　　　Next
　　End If
　　arrList = oDict.keys

　　Application.EnableEvents = False

　　With Range("B3")
　　　　With .Validation
　　　　　　.Delete
　　　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
　　　　　　　　　　　　Operator:=xlBetween, Formula1:=Join(arrList, ",")
　　　　End With
　　　　.Value = (arrList(0))
　　End With

　　Call UniqVal品名((arrList(0)))

　　Application.EnableEvents = True

　　Exit Sub

CrDict_:
　　Set oDict = CreateObject("Scripting.Dictionary")
　　Resume
End Sub

' ' －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

補足

早速のご回答感謝申し上げます。
大変上手く行きました。

ただ、質問のしかたが悪く申し訳ないのですが、

B3:E3の処理を、12行(B14:E14まで)行いたかったのですが、
この場合、単純にセルをコピーしても上手く行きませんでした。

VBAの知識がなく、自分で修正することができません。
補足頂けましたら幸いです。