条件を絞り込んだVBAでのドロップダウンの作り方

質問

いつもお世話になっております。
今、Sheet1のA列に果物名、C列に数字が入力されています。（今回Sheet1のB列は、特に処理の対象とする訳ではないので不要です。）
Sheet2のCells(15,1)に果物名を入力した際、Sheet1のA列の果物名でで絞り込んだC列の数字を、Sheet2のCells(15,2)にドロップダウンリストで表したいです。

当方が考えたロジックは
Sheet1のA列をforで回しSheet2のCells(15,1)と一致した場合に、Sheet1のCells(i,3)の値を、あらかじめ入力規則に設定したセル範囲に転記。一致判定と一致した場合のCells(i,3)の値の転記を繰り返せばドロップダウンが出来上がるのですが、いまいちスマートではないなと思います。
いい方法があればご教示下さい。

回答No.5

Chiquilin

今のやり方で何ら問題ないと思いますけど。

マクロでなくてパラメータクエリでもいいと思います。その場合
抽出データがテーブルになるので参照もしやすいでしょう。

回答No.4

imogasi

#3です。＃３は途中的だったので、参考までに、補足します。
＃３のVBAの実行結果が
Sheet2のD1:F5に
りんご バナナ みかん
1　 2　 3
4　 6　 7
5　 9　 10
8
の形に、できたとして、その後
標準モジュールに
Sub Sample1()
Worksheets("sheet3").Select
For i = 2 To 4
'x = ActiveCell
x = Cells(i, "A")
MsgBox x
Set cc = Worksheets("Sheet2").Range("d1:f1").Find(x)
c = cc.Column
MsgBox c
s1 = Worksheets("sheet2").Name
lr = Worksheets("Sheet2").Cells(1000, c).End(xlUp).Row
MsgBox lr
s2 = Range(Cells(2, c), Cells(lr, c)).Address
With Worksheets("Sheet3").Cells(i, "B").Validation
.Delete
.Add Type:=xlValidateList, _
Operator:=xlEqual, _
Formula1:="=" & s1 & "!" & s2
End With
MsgBox "=" & s1 & "!" & s2
Next i
End Sub
を実行すると（Msgbox行は少数テスト後は、削除のこと）
Sheet3のB列に、A列の値に応じた、選択アイテムをセットします。
ここで考えているのは、Changeイベントを使わない方法のため、
前もってSheet3のA列には選択するデータ（=名前）を、一括して、入力しておくものとします。その後上記VBAを実行すると、Sheet3のB列においては、クリックして現れる選択肢から、クリックして選択すると、A列の名前に対応した選択肢が、ドロップダウンで表示されます。その中から選択すれば、B列には選択された値がセットされます。
＞上記Worksheets("Sheet2").Range("d1:f1").のセル範囲部分（名前見出し部分）は（４列（個）以上に増えても）拡張対応は、コードを少し変えれば可能です。
Sheet3のA列のChangeイベントで上記のVBAに似たものを走らせるのは、なんとなく不安なので、上記の例にしました。
Formula1の右辺は、文字列で指定してますが、エクセルではこれが標準らしい。
他の方法もあるかもしれないが不明。

回答No.3

imogasi

色んな方法があるということで、下記を読んでください。
ーー
エクセルでは、「リスト」のアイテム（項目）は、セル（行とか列）に
具体的に作られている必要があります。普通はある単一列です。
頭で考えたり、プログラムしたら「ルールが決まっている・簡単だ」では、良い方法が設けられていない。
（しかしアクセスなら、例えばコンボのアイテムを、
SQLで選択文のコードそのものを、DataSourceとして書き込む
ことができる。便利です。）
ーー
例えば、A列が「りんご」である行の、C列の値（＝ルールで言えば）の
項目のバラエティをリストに示して、その中から選びたい、は難しい。
ーー
ただし（表Aという）
りんご バナナ みかん（－－＞列）
1　 2　 3
4　 6　 7
5　 9　 10
8
（下方向に列）
のような表が、具体的にエクセルシートに作られておれば、
（有名なやり方ですが、）
https://www.excelspeedup.com/pulldown4/
に解説のある方法で、VBAを使わずに、やれます。エクセルの上級ワザ？
２次元である表から項目（例　みかん）で選べる、ことになる。
ーー
この上記のような表（表A）をVBAで、当初に１回だけ、
シートのセル範囲に作ってしまう方法もあります。
　しかしこういう表の組み換えを「操作」でやるのは結構面倒です。
ソートして、目視で切り貼りすれば表を作るのは簡単で速いすがね。さらなるVBAの勉強のためやプライド（手作業は泥臭い）からやらないでしょう。
ーー
そこで、プログラムで考えれば、
例えば
Sub test01()
lr = Range("A100000").End(xlUp).Row
'MsgBox lr
For i = 2 To lr
k = Cells(i, "A")
Set c = Range(Cells(1, 4), Cells(1, 1000)).Find(k)

If c Is Nothing Then
lc = Cells(1, 1000).End(xlToLeft).Column
MsgBox lc
lc = lc + 1
Cells(1, lc) = k
'--
r = Cells(100000, lc).End(xlUp).Row
MsgBox r
Cells(r + 1, lc) = Cells(i, "C")
Else
lc = c.Column
MsgBox "find column " & lc
r = Cells(100000, lc).End(xlUp).Row
MsgBox r
r = r + 1
Cells(r, lc) = Cells(i, "C")
End If

Next i
End Sub
結果
Sheet1のA-C列に質問のデータがあるとして、実行すると
Sheet1でD列からF列に
りんご バナナ みかん
1 2 3
4 6 7
5 9 10
8
となります。
このD-F列のセル範囲を対象に、前記のWEB記事の方法で、関数と操作で
入力規則を設定すれば、できるでしょう。
ーー
質問のやり方は繰り返し法で対象を見つけているので、小生はあまり気乗りがしない。Filter法とかFind法がよいとおもうが、Filter法はVisibleセルデータを対象にしなければならない難しさがある。でもVBAコードをWEBで探し、慣れればしまいかも。

回答No.2

watabe007

>あらかじめ入力規則に設定したセル範囲に転記。
直接、入力規則の元の値に転記すれば
Sheet2のシートモジュールに
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myList As String
　　Dim c As Range
　　If Target.Address <> "$A$15" Then Exit Sub
　　Range("B15").ClearContents
　　With Worksheets("Sheet1")
　　　　For Each c In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)
　　　　　　If Range("A15").Value = c.Value Then
　　　　　　　　myList = myList & c.Offset(, 2).Value & ","
　　　　　　End If
　　　　Next
　　End With
　　If myList = "" Then myList = " "
　　With Range("B15").Validation
　　　　.Delete
　　　　.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
　　　　xlBetween, Formula1:=myList
　　End With
End Sub

回答No.1

skydaddy

オートフィルターを使って絞り込み、必要な行数をカウントすれば簡単かと。
オートフィルターの使い方は例えばこちら。
http://officetanaka.net/excel/vba/tips/tips155.htm

Sheet1の表をいじりたくなければ、Sheet3を作業用としてSheet１から呼び出される時にコピーするようにすれば良いと思います。