下記のような【会社】というシートがあります。
[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ベストアンサー
- 回答日時:
こんな感じかなー?
[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
- 回答日時:
No.3です。
たびたびごめんなさい。
前回のSheet2のA1セル「リスト」の元の値の欄の数式ですが
前回のままでも大丈夫ですが、
↓の数式に変更してください。
=OFFSET(E1,1,,COUNTA(E:E)-1)
どうも失礼しました。m(_ _)m
No.3
- 回答日時:
こんばんは!
面白そうなのでちょっとやってみました。
↓の画像で左側が「会社」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
- 回答日時:
できます。
昔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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) Excel VBA 最終行を取得しVlookup関数をコピーする方法をコーディングで教えてください。 3 2023/05/11 13:14
- Excel(エクセル) Excelマクロ 差分抽出の方法が知りたいです。 2 2023/03/07 13:25
- Excel(エクセル) ユーザー定義について質問です。 2 2023/06/28 13:21
- Excel(エクセル) EXCEL 関数を教えてください。(A列の同じ値が複数ある場合vlookupで出来ますか) 4 2022/12/07 20:54
- Excel(エクセル) エクセルで”入力シート”の文字書式の変更を”出力シート”で同じ文字書式で印刷したいです。VBA希望 4 2023/04/24 11:07
- Excel(エクセル) Excelマクロの差分抽出のコードを教えていただきたいです。 2 2023/03/14 11:40
- Excel(エクセル) エクセルの条件付き書式 個人シートを参照して集計シートに色付けしたい 1 2023/06/22 00:39
- Visual Basic(VBA) vbaエクセルマクロ RemoveDuplicatesについて RemoveDuplicatesを使 3 2023/02/28 01:13
- Visual Basic(VBA) エクセルについて教えてください。 3 2023/06/28 09:11
- Visual Basic(VBA) エクセルのマクロで対象ごとにシート分けしてその内容をセルに書き込みたい 9 2022/08/24 13:23
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【関数】スペースがいくつ入っ...
-
西暦や和暦の表示をyyyymmdd表...
-
【Microsoft Office Excel Comp...
-
Excelはなんで先頭の0を消すん...
-
Excelのセルを飛ばして入力する
-
別シートからの文字を変更
-
エクセルの行の抽出について質...
-
Excelのオートフィル
-
Excel 2019 のピボットテーブル...
-
スプレッドシート クエリ関数 1...
-
excelの不要な行の削除ができな...
-
Excel初心者です。 詳しい方、...
-
【Excel】セル内の時間帯が特定...
-
Excel初心者です。 詳しい方、...
-
EXACT関数とIF関数の組み合わせ...
-
Excelのグラフ軸について
-
スマートな関数を教えて下さい。
-
Excelで全角を半角にしたいので...
-
【マクロ】エクセルにかいてあ...
-
Excel:一部のフォントでセルの...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ファイル内にある数字の出現回...
-
Excel関数の先頭に「@」が入っ...
-
エクセルの気味悪い不思議
-
Excel VBAで、実行時にsheet上...
-
表示されている人数だけを数え...
-
他人が作ったマクロの理解
-
Excelの関数について質問です。
-
Excel 集計表
-
エクセル 日時の計算式について
-
Excelの関数に関して質問です。...
-
エクセル:セル内の文字列の下...
-
絞り込み検索
-
エクセルの関数で
-
エクセルの書式設定について教...
-
余分なEXCELファイルに印刷され...
-
VBA 同一シート内での転記の仕方
-
長期休みの関数はありますか
-
Excelの空のセル
-
エクセルで入力してある文を別...
-
Excelのマクロで、セルを結合し...
おすすめ情報