データシートから他のシートへ抽出

質問

元データ：(2)データシート
抽出シート：(6)抽出シート

(2)データシートには、
　　　B　　　　　C　　　　D　　　　E　　　 F　　　 G・・・・・・P
4　(項目)　(内容)　　(数量) (単位)　(単価) 　(金額)　(仕入先)
5　りんご　　 果物　　　1　　　　個　　100　　　100　　　A商店
6　みかん　　果物　　　2　　　　個　　100　　　200　　　B商店
7　ジュース　飲料　　　3　　　　本　　100　　　300　　　A商店
8　牛乳　　　 飲料　　　2　　　　本　　100　　　200　　　A商店
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
とあります。　
これを(6)抽出シートのA3セルに仕入先名を入れることで、
(6)抽出シート

　　A　　　B　　 　C　　 　 D　　　E　　　F　　　G
3　A商店　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
21　　　(項目)　(内容)　(数量)(単位)(単価)(金額)
22　　　りんご　　果物　　　1　　　個　100　　100
23　　　ジュース　飲料　　 3　　　本　100　　300
24　　　　牛乳　　飲料　　　2　　　本　100　　200
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
上記の様にB22(項目)、C22(内容)、D22(数量)等を抽出したいのですが、VLOOKUPを使ってもりんごのみを何件も抽出したりで困ってます。

ちなみに(6)抽出シートはある程度の雛形が決まっています。
何かいい方法はありますでしょうか。
どうぞご教授宜しくお願い致します。
図が変になってしまってすいません。

回答No.2

ham_kamo · ベストアンサー

No.1です。補足拝見しました。
結合セルに対応するように修正してみました。
列番号が連続しなくなったので、まとめて１行文を処理していた部分を列ごとにばらして書いているので、ちょっと長くなってしまいました。

Private Sub Worksheet_Change(ByVal Target As Range)
　If Target.Cells(1, 1).Address <> "$A$3" Then Exit Sub

　Dim i As Integer, j As Integer, N As Integer
　Dim WS1 As Worksheet, WS2 As Worksheet
　Set WS1 = Worksheets("データシート") 'データシート名を指定
　Set WS2 = ActiveSheet
　Application.ScreenUpdating = False
　Application.EnableEvents = False
　j = 22
　For i = 5 To WS1.Cells(Rows.Count, "B").End(xlUp).Row
　　If WS1.Cells(i, "P").Value = WS2.Range("A3").Value Then
　　　WS2.Cells(j, "B").Value = WS1.Cells(i, "B").Value
　　　WS2.Cells(j, "D").Value = WS1.Cells(i, "C").Value
　　　WS2.Cells(j, "G").Resize(1, 2).Value = WS1.Cells(i, "D").Resize(1, 2).Value
　　　WS2.Cells(j, "I").Value = WS1.Cells(i, "F").Value
　　　WS2.Cells(j, "M").Value = WS1.Cells(i, "G").Value
　　　j = j + 1
　　End If
　Next
　Do While WS2.Cells(j, "B").Value <> ""
　　WS2.Cells(j, "B").MergeArea.ClearContents
　　WS2.Cells(j, "D").MergeArea.ClearContents
　　WS2.Cells(j, "G").Resize(1, 2).ClearContents
　　WS2.Cells(j, "I").MergeArea.ClearContents
　　WS2.Cells(j, "M").MergeArea.ClearContents
　　j = j + 1
　Loop
　Application.EnableEvents = True
　Application.ScreenUpdating = True
End Sub

うまく動かないときなどは、また補足をお願いします。

お礼

見事動きました。
大変丁寧な回答を頂きまして、感謝しております。
ham_kamoさん、誠にありがとうございました。

回答No.1

ham_kamo

数式を組み合わせてやろうと思ったのですが、かなり複雑になってしまい、またデータ数が多い場合はかなり重たくなってしまう可能性があるのでマクロにしてみました。

抽出シートのシートタブを右クリックして「コードの表示」を選択するとVBAの画面が出るので、そこに以下のマクロをコピーして貼り付けてみてください。
（マクロ中に出てくる"データシート"という箇所は実際のシート名に即して変更してください）

Private Sub Worksheet_Change(ByVal Target As Range)
　If Target.Cells(1, 1).Address <> "$A$3" Then Exit Sub

　Dim i As Integer, j As Integer
　Dim WS1 As Worksheet, WS2 As Worksheet
　Set WS1 = Worksheets("データシート") 'データシート名を指定
　Set WS2 = ActiveSheet
　Application.ScreenUpdating = False
　Application.EnableEvents = False
　If WS2.Range("B22").Value <> "" Then
　　WS2.Range(Cells(22, "B"), Cells(Rows.Count, "G").End(xlUp)).ClearContents
　End If
　j = 22
　For i = 5 To WS1.Cells(Rows.Count, "B").End(xlUp).Row
　　If WS1.Cells(i, "P").Value = WS2.Range("A3").Value Then
　　　WS2.Cells(j, "B").Resize(1, 6).Value = WS1.Cells(i, "B").Resize(1, 6).Value
　　　j = j + 1
　　End If
　Next
　Application.EnableEvents = True
　Application.ScreenUpdating = True
End Sub

貼り付けたらVBAの画面を閉じてかまいません。
これで、抽出シートのA3セルの仕入れ先名称を書き換えたらその仕入れ先の抽出されます。

お礼

ご回答、誠にありがとうございます。
教えて頂いたマクロでほぼ出来かけているのですが、
私のミスで(6)抽出シートの方が、

　　A　　BC　　　DEF　　　Ｇ　　Ｈ　　　　IJKL　　MNOPQ
3　A商店　　　　　　　　　　　　　　　
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
21　　　(項目)　(内容)　(数量)(単位)　　(単価)　(金額)
22　　　りんご　　果物　　　1　　個　　　　100　　　100
23　　 ジュース　飲料　　　3　　本　　　　100　　　300
24　　　　牛乳　　飲料　　　2　　本　　　　100　　　200
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
　　　　　　　　　　　　　　　・
という風にBC(項目)、DEF(内容)、G(数量)、H(単位）、IJKL（単位）
MNOPQ（金額）という結合セルなのです。
ご回答頂いたマクロを実行した所、（項目）部分は完全に抽出出来たのですが、（内容）以降は少しずれて抽出されました。

私の説明ミスで誠に申し訳ありませんが、ご教授頂ければと
思ってます。どうぞ宜しくお願い致します。