入力規則とフィルター

質問

エクセルで質問ですが、マクロ、VBAにて
できるかどうか判らない状態での質問になりますが
ご理解願います。

シート2の1行目には表題、2行目から
表題に準じたデータが入力されています。

　　A　　　　　B　　　　　C
1　顧客名　　　日付　　　取引内容

シート1にはA1、A2、C2に表題が入っております。

　　A　　　　　B　　　　　C　　　　　D
1　顧客名　　　
2　日付　　　　　　　　　取引内容

シート1のB1を選んだ際に、シート2のA列を参照したデータから
リスト選択できる様にしたいと考えています。
その際、シート1のB2にて顧客名を選択した時点で
その顧客名を条件としたオートフィルタ―を
シート2で掛けたいのですが、ご指導願います。

回答No.3

keithin · ベストアンサー

＞追加で質問なのですが、

いいえ，お断りします。「ついでに聞いちゃえ」でダラダラと終わらないご相談があんまり多くて，困っています。
問題が解決したご相談はキチンと解決で閉じ，新しいご質問は改めて「こんどはこういう状況から，次はこういう結果が欲しい」と改めて状況をしっかり提示して，新しいご相談で投稿するようにしてください。

でもマクロを少し手直しますので，次の通りにします。

手順：
シート２を右クリックしてコードの表示を選び，現れたシートのマクロを全部削除して下記をコピー貼り付ける

private sub worksheet_change(byval Target as excel.range)
　dim i as long
　dim myDic as object
　if application.intersect(target, range("A:A")) is nothing then exit sub

　set mydic = createobject("Scripting.Dictionary")
　on error resume next
　for i = 2 to cells.specialcells(xlcelltypelastcell).row
　if cells(i, 1) <> "" then
　mydic.add cells(i, 1).value, cells(i, 1).value
　end if
　next i

　with worksheets("Sheet1").range("B1").validation
　　.delete
　　.add type:=xlvalidatelist, formula1:=join(mydic.keys, ",")
　end with
　set mydic = nothing
end sub

private sub worksheet_beforedoubleclick(byval Target as excel.range, cancel as boolean)
　if target = "" then exit sub
　cells(target.row, "B").resize(1, 2).copy destination:=worksheets("Sheet3").range("A1")
　cancel = true
end sub

ファイルメニューから終了してエクセルに戻る
コピーしたいセルをＷクリックすると，シート２からシート３に転記する。

お礼

助言と共に、ご指導頂き有難うございました。
実は他にも気になる場所があるのですが
どこまでVBAで動作可能なのか判らなかった為
小分けにして質問してしまった事をお詫びいたします。
次回は一括で質問したいと思います。

回答No.2

imogasi

>シート1のB1を選んだ際に、シート2のA列を参照したデータから
リスト選択できる様にしたいと考えています。
Ｂ１は、A1の誤りでは？
ーー
＞リスト選択できる様にしたいと考えています。
リスト選択とは何？Ｓｈｅｅｔ２はリスト状態にあると思うが、その中から検索したいということだろう。表現に気をｔ付けて、丁寧に。
質問例には見出しだけでなくデータ例も入れることが望ましい。エクセルの解説書を見てご覧、入れてあるよ。
ーー
言葉で言えば、
シート１でＡ１セルに顧客名を入れたら、シート２のＡ列でその顧客名の行を探し、該当行の日付、取引内容を参照して、シート１のＡ２，Ｂ２のセットしたい
と書けばわかりやすいだろう。
顧客名はシート２のＡ列で複数表れないのだろうね。こういうことをはっきり書いておくのが、わかった人のやること。
ーー
この質問のエクセルのシートでの操作をして、マクロの記録を取って、コードを見て、本番では何処が変わるかコードを対応したものにする、やり方を勉強したら。
ーー
この課題はエクセル関数で出来るのではないか。（顧客名はシート２のＡ列で複数表れない場合は）
ＶＢＡなんて無理しないで関数でやって、良いのではないか。
関数をほぼそのままで、ＶＢＡで使えるが。

回答No.1

keithin

シート２のシート名タブを右クリックしてコードの表示を選び，下記をコピー貼り付ける

private sub worksheet_change(byval Target as excel.range)
　dim i as long
　dim myDic as object
　if application.intersect(target, range("A:A")) is nothing then exit sub

　set mydic = createobject("Scripting.Dictionary")
　on error resume next
　for i = 2 to range("A65536").end(xlup).row
　mydic.add cells(i, 1).value, cells(i, 1).value
　next i

　with worksheets("Sheet1").range("B1").validation
　　.delete
　　.add type:=xlvalidatelist, formula1:=join(mydic.keys, ",")
　end with
　set mydic = nothing
end sub

シート１のシート名タブを右クリックしてコードの表示を選び，下記をコピー貼り付ける

private sub worksheet_change(byval Target as excel.range)
　if target.address <>"$B$1" then exit sub
　if target = "" then worksheets("Sheet2").autofiltermode = false : exit sub
　worksheets("Sheet2").range("A:C").autofilter field:=1, criteria1:=target.value
end sub

シート２のリストを更新すると，シート１のＢ１の「入力規則」を更新する
シート１のＢ１を選択すると，シート２に「オートフィルタ」を掛ける。

補足

お礼が遅くなりました。
深夜にもかかわらず、即回答頂き有難うございます。

ほぼ思い通りの動作確認ができました。
keithin様に追加で質問なのですが、
オートフィルターを掛けたのち
任意のセルを指定して（例えば抽出結果のB5:C5）
別のシート（例えばシート3）のA1:B1に貼り付ける
マクロはないでしょうか？
任意のセルは抽出結果に応じて変動しますので
手動選択が有りがたいです。
貼り付け先は固定です。