VBA 別ブックから該当データを検索し、複数の数値を固定の列に転記

一覧表というBookがあります
№　タイトル　　店番　　種類　　コード①　　コード②　　コード③
1 　aaaaaaa 　(空欄)　　AA　　　(空欄)　　　(空欄)　　　(空欄)
2　bbbbbbb 　　〃　　　BB　　　　〃　　　　　〃　　　　　〃
3　　・
4　　・
5　　・
この様な表になっています
別の集約表というBookに
タイトル　　店番　コード②　コード③　コード①
cccccccc 　 25　　 5.26　　3.33 　　　 4.44
bbbbbbb 　 - 　　　 - 　　　 - 　　　 -
sssssssss 45　　 8.45 　　 6.55　　 8.88
aaaaaaaa 88 　　7.65　　　 8.15　　　3.77
mmmmm
タイトルは同じなのですが、順番がバラバラになっています

集約表の店番、コード①②③の４つを一覧表に転記したいのですが・・・
20000件以上のデータがある為、マクロを使用して自動転記を行いたいのです
マクロの登録は集約表か別の新しいBookに登録したいです。


初心者のため細かいマクロの記述が出来ず申し訳ありませんが
出来れば詳しく教えて頂けないでしょうか
よろしくお願いいたします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2016/12/17 22:58

こんばんは！

↓の画像のような配置で
元データは「集約表」Bookの「Sheet1」にあるとし、「一覧表」BookのSheet1に表示させるとします。

＞20000件以上のデータがある為・・・
とは「一覧表」Bookの方になるのでしょうか？

そうであればループさせるようにしていますので、結構時間がかかると思います。

一例です。「一覧表」Bookの標準モジュールにしてください。
尚、「集約表」Bookが開いていない場合は開くところからやっています。

Sub Sample1()
Dim i As Long, c As Range
Dim myPath As String, fN As String
Dim wB As Workbook, wS As Worksheet
myPath = "保存場所のパス" & "\"
fN = "集約表.xlsx"
Application.ScreenUpdating = False
'▼集約表Bookが開いていない場合は開く//
If Workbooks.Count = 1 Then
Workbooks.Open myPath & fN
End If
Set wB = Workbooks(fN)
Set wS = wB.Worksheets("Sheet1")
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "B"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Cells(i, "C") = wS.Cells(c.Row, "B")
.Cells(i, "E") = wS.Cells(c.Row, "E")
.Cells(i, "F") = wS.Cells(c.Row, "C")
.Cells(i, "G") = wS.Cells(i, "D")
End If
Next i
Application.ScreenUpdating = True
.Activate
End With
MsgBox "完了"
End Sub

※　コード内の「保存場所のパス」の部分は
実際のパスにしてください。
保存場所のファイル上で右クリック　→　プロパティ　で確認してください。m(_ _)m

この回答へのお礼

回答ありがとうございます。
思ってた通りの形に出来ました！
とても助かりました。

お礼日時：2016/12/18 19:47