エクセル2010での質問です。

質問

下記のような【会社】というシートがあります。
[A社]がA1セルです。

[A社][A支店][田中][鈴木]
[B社][B支店][山田][加藤]
[C社][C支店][小野]
[A社][D支店][島田][今田]
[B社][E支店][佐藤][山本]
[C社][F支店][小山][三浦]

別のシートのA1に、【会社】のシートA列の文字を重複させずにプルダウンを作成し、[A社]を選ぶと

別のシートのB1に、【会社】シートのB列を探し、A支店・D支店のプルダウンを作成し、[A支店]を選ぶと

別のシートのC1に、【会社】シートのCD列を探し、[田中][鈴木]のプルダウンを作成する。

VBAでこのようなことは出来ますか？
説明が下手で申し訳ございません。

回答No.1

eden3616 · ベストアンサー

こんな感じかなー？

[A社][A支店][田中][鈴木]

の「[ ]」がセルを区切る記号なのか、値として含んでいるものなのか分かりませんので
C1セルに設定するブルタウンの内容はC列D列を結合しただけにしています

▼コードの追加方法▼

(1)Alt+F11でVBEを開く

(2)左上の「プロジェクト」ペインにある対象のブックの「ThisWorkbook」を右クリック

(3)「コードの表示」を選択

(4)右側のペインにカーソルが移るので最下のVBAコードを貼付

(5)コード内の「'設定」の4行を以下を参考に確認・修正
　Set mySt(0) = Sheets("会社")
　　　・・・　シート名を設定
　Set mySt(1) = ActiveSheet
　　　・・・　現在表示されているシートにブルタウンリストを作成する
　　　　（「別のシート」が固定の場合は「= Sheets("別のシート名")」としてください）
　myCol = "A"
　　　・・・　"会社"シートのデータで左側の列記号を設定（○社が入っている列）
　tarCel = "A1"
　　　・・・　「別のシート」の1つ目のブルタウンリストを作成する基準セルを指定
　　　　（このセルを基準に、右隣に1つ、2つ目のセルに支店・名前のリストが作成される）

(6)右上の×またはAlt+F11でVBEを閉じる

▼マクロの使用方法▼

(7)対象のシート（ご質問によるとこの「別のシート」）を表示した状態にする

(8)Alt+F8または表示→マクロから「ThisWorkbook!リスト取得」を選択して実行

(9)
現在表示しているシートのセル「A1」にブルタウンリストが作成されていますので
リストから値を選択してください。
B1、C1と順にリストを選択するたびに次のブルタウンリストが作成されます。

※以降
(7)(8)を実行すると、設定されている値・リストが初期化され、
(9)で選択する事が出来ます。

■VBAコード

'共通変数
Dim mySt(1) As Worksheet
Dim myCol As String
Dim tarCel As String
Dim i As Long, j As Long
Dim flag As Integer
Dim lst() As String

Sub リスト取得()
'エラー対策
Application.EnableEvents = True

'設定
Set mySt(0) = Sheets("会社")
Set mySt(1) = ActiveSheet
myCol = "A"
tarCel = "A1"

'mySt(0)がアクティブ時に処理停止
If mySt(0).Name = ActiveSheet.Name Then
　　MsgBox "シート""" & mySt(0).Name & """に対しては実行できません"
　　Exit Sub
End If
'現在のリスト・値を削除
With Range(mySt(1).Range(tarCel).Offset(0, 0), mySt(1).Range(tarCel).Offset(0, 3))
　　.ClearContents
　　.Validation.Delete
End With
'リストセット処理を実行
Call setList("", 0)
End Sub

'リストが変更されたら実行
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If mySt(1) Is Nothing Then Exit Sub
With mySt(1).Range(tarCel)
　　Select Case Target.Address
　　Case .Offset(0, 0).Address
　　　　Call setList(.Offset(0, 0).Value, 1)
　　Case .Offset(0, 1).Address
　　　　Call setList(.Offset(0, 1).Value, 2)
　　End Select
End With
End Sub

'リストセット処理
Private Sub setList(key As String, ost As Integer)
On Error GoTo era
'リストを配列に格納
ReDim lst(0)
With mySt(0)
　　For i = 1 To .Cells(Rows.Count, myCol).End(xlUp).Row
　　　　If ost = 2 Or key = "" Or .Cells(i, myCol).Value = key Then
　　　　　　flag = 1
　　　　　　If ost = 2 Then
　　　　　　　　If .Cells(i, myCol).Offset(0, 0).Value <> mySt(1).Range(tarCel).Offset(0, 0).Value _
　　　　　　　　　　Or .Cells(i, myCol).Offset(0, 1).Value <> mySt(1).Range(tarCel).Offset(0, 1).Value Then
　　　　　　　　　　flag = 0
　　　　　　　　End If
　　　　　　Else
　　　　　　　　For j = 0 To UBound(lst)
　　　　　　　　　　If lst(j) = .Cells(i, myCol).Offset(0, ost).Value Then
　　　　　　　　　　　　flag = 0
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　End If
　　　　　　If flag Then
　　　　　　　　If ost = 2 Then
　　　　　　　　　　lst(UBound(lst)) = .Cells(i, myCol).Offset(0, ost).Value & .Cells(i, myCol).Offset(0, ost + 1).Value
　　　　　　　　Else
　　　　　　　　　　lst(UBound(lst)) = .Cells(i, myCol).Offset(0, ost).Value
　　　　　　　　End If
　　　　　　　　ReDim Preserve lst(UBound(lst) + 1)
　　　　　　End If
　　　　End If
　　Next i
End With
'リストの作成
With mySt(1).Range(tarCel).Offset(0, ost)
　　Application.EnableEvents = False
　　.ClearContents
　　With .Validation
　　　　.Delete
　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
　　　　xlBetween, Formula1:=Join(lst, ",")
　　End With
　　Application.EnableEvents = True
End With
Exit Sub
era:
'エラー処理
Application.EnableEvents = True
MsgBox "値が不正です"
End Sub

回答No.4

tom04

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

前回のSheet2のA1セル「リスト」の元の値の欄の数式ですが
前回のままでも大丈夫ですが、
↓の数式に変更してください。
=OFFSET(E1,1,,COUNTA(E:E)-1)

どうも失礼しました。m(_ _)m

回答No.3

tom04

こんばんは！
面白そうなのでちょっとやってみました。

↓の画像で左側が「会社」Sheet・右側が操作するSheet2とします。
Sheet2に「リスト」表示させるための作業用の列を3列（E～G列）設けています。

まず、標準モジュールに↓のコードをコピー＆ペーストしておいてください。

Dim lastRow As Long, wS As Worksheet 'この行から
Sub 表示1()
Set wS = Worksheets("会社")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
With Worksheets("Sheet2")
wS.Range("A1").AutoFilter field:=1, Criteria1:=.Range("A1")
Range(wS.Cells(1, "B"), wS.Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy .Range("F1")
End With
Application.ScreenUpdating = True
End Sub

Sub 表示2()
Set wS = Worksheets("会社")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
On Error Resume Next '←念のため
Application.ScreenUpdating = False
With Worksheets("Sheet2")
wS.Range("A1").AutoFilter field:=2, Criteria1:=.Range("B1")
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy .Range("G1")
.Range("I1").Cut .Range("G1")
.Range("J1").Cut .Range("G2")
.Range("H1").Clear
End With
wS.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub 'この行まで

つぎにSheet2のシートモジュールで↓のコードをコピー＆ペースト

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'この行から
Dim wS As Worksheet
Set wS = Worksheets("会社")
If Target.Address = "$A$1" Then
Application.ScreenUpdating = False
Range("B1:D1").ClearContents
wS.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("E1"), unique:=True
Application.ScreenUpdating = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Range("G:G").Clear
Call 表示1
End If
If Target.Address = "$B$1" Then
Range("C1").ClearContents
Range("H:H").Clear
Call 表示2
End If
End Sub 'この行まで

そしてSheet2のA1セルに入力規則の「リスト」の設定をします。
A1セルのリストの「元の値」の欄に
=OFFSET(Extract,1,,COUNTA(E:E)-1)
という数式を入れOK

同じくB1セルのリストの「元の値」の欄に
=OFFSET(F1,1,,COUNTA(F:F)-1)
としてOK

最後にC1セルのリストの「元の値」の欄は直接セルを選択し
=$G$1:$G$2
としておきます。

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

※　作業列が目障りであれば非表示にしておいてください。m(_ _)m

回答No.2

mitarashi

できます。昔XMLを勉強していて思いつきで作ったコードです。都度検索せず、最初にツリー状のリストを生成し、順次辿ります。
分かり易いコードは他の回答者の方のご回答をお待ち下さい。
リストがSheet2にあるとして、Sheet1のA～D列に動的にプルダウンを順次生成します。（任意段階に対応可能なコードです。5段階までは試しています）
既入力セルに対してプルダウンを設定するかどうか等はアレンジが必要です。

☆標準モジュール
'Microsoft XML V3.0に参照設定
Public oXMLDom As DOMDocument30
Public myColumnCount As Long

Public Sub setDOM()
Dim i As Long, j As Long, k As Long
Dim myXPath As String
Dim targetRange As Range
Dim buf As Variant
Dim root As IXMLDOMElement

Set oXMLDom = New DOMDocument30
settingDOM oXMLDom
setInfo oXMLDom, "xml test"
Set targetRange = ThisWorkbook.Sheets("Sheet2").Range("A1").CurrentRegion
buf = targetRange.Value
Set root = oXMLDom.createElement("root")
oXMLDom.appendChild root
myColumnCount = UBound(buf, 1)

For i = 1 To UBound(buf, 2)
Call addElement(root, i, buf)
Next i
End Sub

Sub addElement(root As IXMLDOMElement, level As Long, buf As Variant)
Dim i As Long, j As Long
Dim parentElement As IXMLDOMElement
Dim newElement As IXMLDOMElement
Dim myXPath As String
Dim retNode As IXMLDOMNodeList

For i = 1 To UBound(buf, 1)
myXPath = "/" & root.nodeName
For j = 1 To level - 1
If level > 1 Then myXPath = myXPath & "/" & buf(i, j)
Next j

Set parentElement = root.SelectSingleNode(myXPath)
　　'空だとエラーになるので、アンダーバーで置換えます
Set retNode = root.SelectNodes(myXPath & "/" & IIf(buf(i, level) = "", "_", buf(i, level)))
If retNode.Length = 0 Then
Set newElement = oXMLDom.createElement(IIf(buf(i, level) = "", "_", buf(i, level)))
parentElement.appendChild newElement
End If
Next i
End Sub

'MSXMLDOMの設定
Private Sub settingDOM(ByRef dom As DOMDocument30)
With dom
.async = False
.validateOnParse = False
.resolveExternals = False
.preserveWhiteSpace = True
.setProperty "SelectionLanguage", "XPath"
End With
End Sub

Private Sub setInfo(ByRef dom As DOMDocument30, comment As String)
Dim node As IXMLDOMNode

Set node = dom.createProcessingInstruction("xml", "version=""1.0"" encoding=""Shift_JIS""")
dom.appendChild node
Set node = Nothing
Set node = dom.createComment(comment)
dom.appendChild node
Set node = Nothing
End Sub

☆Sheet1モジュール
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim dummy As Range

If oXMLDom Is Nothing Then setDOM
If target.Columns.Count > 1 Then Exit Sub 'シート全体選択時のオーバーフロー対策
If target.Cells.Count > 1 Then Exit Sub
If target.Column > myColumnCount Then Exit Sub
If target.Column > 1 Then
On Error Resume Next
Set dummy = Intersect(target.Offset(0, -1), target.Offset(0, -1).SpecialCells(xlCellTypeAllValidation))
On Error GoTo 0
If dummy Is Nothing Then Exit Sub
End If
setValidation target
End Sub

Private Sub setValidation(target As Range)
Dim i As Long, j As Long
Dim myXPath As String
Dim root As IXMLDOMElement
Dim retNode As IXMLDOMNodeList
Dim strValidation As String

Set root = oXMLDom.DocumentElement

On Error GoTo errorHandle
If target.Column = 1 Then
Set retNode = root.ChildNodes
Else
myXPath = "/" & root.nodeName
For j = target.Column - 1 To 1 Step -1
myXPath = myXPath & "/" & target.Offset(0, -1 * j)
Next j
Set retNode = root.SelectSingleNode(myXPath).ChildNodes
End If
If retNode Is Nothing Then Exit Sub
For i = 0 To retNode.Length - 1
If strValidation = "" Then
strValidation = retNode(i).nodeName
Else
strValidation = strValidation & "," & retNode(i).nodeName
End If
setvalidationSub target, strValidation
Next i
errorHandle:
End Sub

Private Sub setvalidationSub(target As Range, strValidation As String)
With target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strValidation
End With
End Sub
'Deactivateで入力規則を消去（お好みで）
Private Sub Worksheet_Deactivate()
Cells.SpecialCells(xlCellTypeAllValidation).Validation.Delete
Set oXMLDom = Nothing
End Sub