【VBA】別シートのデータを複数回抽出

［前提］
VBAにて集計表を作成しております。
集計元は今のところ[data]1つのシートにまとまっています。
[data]シートと同じエクセルファイルに「集計」シートがあります。
[data]シートはA列からAB列まであります。A列はCからH列を”＆”で結合したものをB列にいったん貼りつけ、さらにコピーして、値としてA列に貼り付けました。

集計シート

［やりたいこと］
①集計元のシート（[data]が記載されている）　→　必要なデータを抽出　→　集計先のセルA2に貼り付け
②集計元のシート（[data]が記載されている）　→　さらに必要なデータを抽出　→　集計先の①の下に貼り付け
③　②を繰り返す

キーワードを「集計」シートに作成したH1の検索欄に入れる。キーワードにマッチする行を見つけ[data]から選択し「集計」シートに転記
さらに次に欲しいデータを順番に検索し、結果を最初に検索し転記したセルの末尾に貼り付けし、一覧表を作る。
H1でヒットするものは、１行の時もありますが、３行のときもあります。
シートからA列、I列、J列のみコピーしたいと思っています。
下記のコードで１回の検索はできますが、複数回検索し、貼り付けの繰り返し検索したいときの集計のマクロ記載がどう作成すればいいのか分かりません。

Sub
1
2i = Sheets("集計").Range("H2")
3
4Sheets("Data").Select
5Range("A1:AB1048576").AutoFilter field:=1, Criteria1:=i
6        
7Range("A2:A1048576,I2:I1048576,J2:J1048576").Copy
8Sheets("集計").Range("A2:C1048576").PasteSpecial
9
10End Sub
11
12コード

行動規範の内容に同意します

回答1件

ベストアンサー

ExcelVBA
1Sub test2()
2    Dim sKey As String
3    
4    '抽出キーワードの取得
5    sKey = Sheets("集計").Range("H2").Text
6    'オートフィルターでキーワードを含むデータを抽出し、I:J列をコピー
7    With Sheets("Data").AutoFilter.Range
8        .AutoFilter field:=1, Criteria1:=sKey
9        .Offset(1).Columns("I:J").Copy
10    End With
11    '集計シートの２列目の最後の行の下に貼付
12    With Sheets("集計").Range("A1").CurrentRegion
13        .Cells(.Rows.Count + 1, 2).PasteSpecial
14    End With
15    '１列目の空欄を検索したキーワードで埋める
16    Sheets("集計").Range("A1").CurrentRegion _
17            .Columns(1).SpecialCells(xlCellTypeBlanks).Value = sKey
18End Sub

とりあえず、とっ散らかっているこーどを纏めるとこんな感じですかね。

1回の中でオートフィルターを設定して解除するようにしました。

ExcelVBA
1Option Explicit
2
3Sub test2()
4    Dim sKey As String
5
6    '抽出キーワードの取得
7    sKey = Sheets("集計").Range("H2").Text
8    'オートフィルターでキーワードを含むデータを抽出し、I:J列をコピー
9    With Sheets("Data").Range("A1").CurrentRegion
10        .AutoFilter field:=1, Criteria1:=sKey
11        .Offset(1).Columns("I:J").Copy
12    End With
13    '集計シートの２列目の最後の行の下に貼付
14    With Sheets("集計").Range("A1").CurrentRegion
15        .Cells(.Rows.Count + 1, 2).PasteSpecial
16    End With
17    '１列目の空欄を検索したキーワードで埋める
18    Sheets("集計").Range("A1").CurrentRegion _
19            .Columns(1).SpecialCells(xlCellTypeBlanks).Value = sKey
20            
21    'オートフィルター解除
22    Sheets("Data").AutoFilter.Range.AutoFilter
23End Sub