VBAで別のブックの値をVlookup関数で検索し、シートに貼り付けたい

Sheet1.xlsm A列のコードを参考にリスト.xlsxからVlookupで値を検索して
Sheet1のG列、H列、I列、K列、L列、M列に値を貼り付けたいです。（J列には別のデータが入りますので空白です）

マクロは全くの初心者なのですが、仕事で指示を受け困っています。
参考書片手に試行錯誤してG4への貼り付けができるように下記のようにつくってみましたが、うまく動きません。

初歩的な内容で大変申し訳ないのですが、ご教示いただけますでしょうか？

＜補足＞
・Sheet1へは100件程度貼り付けたいコードが入っています。
・リスト内データは1000件あります。

Option Explicit
Sub データ転記()
Application.ScreenUpdating = False
Dim I As Long
Dim xlBook
Set xlBook = Workbooks.Open("C:\Users\wwsd111\Documents\リスト.xlsx")
I = 2
Do While Range("A" & I).Value <> ""
ThisWorkbook.Worksheets("Sheet1").Range("G" & I).Value = Application.VLookup(ThisWorkbook.Worksheets("C:\Users\wwsd111\Documents\リスト.xlsx").Range("B" & I).Value, xlBook.Worksheets("C:\Users\wwsd111\Documents\リスト.xlsx").Range("A7:G1000"), 2, 0)
I = I + 1
Loop
xlBook.Close
Application.ScreenUpdating = True
MsgBox ("完了")
End Sub

No.2 回答者： tom04 回答日時： 2017/11/10 18:10

No.1です。

＞Sheet1の4行目以降にリストから抽出したデータを入力することができるか・・・
前回のコードは2行目からのループにしていました。
始まりは4行目からなのですね。
おそらく空白セルを参照してしまい、最初の空白行が表示されたのではないかと思います。

そして、もう一度コードを拝見するとG列に表示するのはVLOOKUP関数の
検索値　→　「Sheet1」のB列
範囲　　→　開いたブックのA～G列の2列目すなわちB列（完全一致）
となっていますね。

画像が小さすぎて詳細が判らないのですが、
「Sheet1」のB列には何も入っていないように見えます。
そのため前回のコードはA列を検索値としていました。

もう一つ質問文に
＞Sheet1のG列、H列、I列、K列、L列、M列に値を貼り付けたいです
とありますが、
開いたブック（Sheet）のどの列を当てはめれば良いのでしょうか？
その辺が判りませんので、とりあえずG列以降に表示するのは開いたSheetのB列～G列の順にしています。
↓のコードに変更してみてください。

Sub Sample2()
Dim i As Long, c As Range, wB As Workbook, wS As Worksheet
Dim myPath As String, fN As String
myPath = "C:\Users\wwsd111\Documents" & "\"
fN = "リスト.xlsx"
Application.ScreenUpdating = False
Workbooks.Open myPath & fN
Set wB = ActiveWorkbook
Set wS = wB.Worksheets(1)
With ThisWorkbook.Worksheets("Sheet1")
For i = 4 To .Cells(Rows.Count, "B").End(xlUp).Row '//4行目～B列最終行まで★//
If .Cells(i, "B") <> "" Then '//←追加//
Set c = wS.Range("B:B").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole) '//★//
If Not c Is Nothing Then
.Cells(i, "G") = wS.Cells(c.Row, "B") '//★//
.Cells(i, "H") = wS.Cells(c.Row, "C") '//？//
.Cells(i, "I") = wS.Cells(c.Row, "D") '//？//
.Cells(i, "K") = wS.Cells(c.Row, "E") '//？//
.Cells(i, "L") = wS.Cells(c.Row, "F") '//？//
.Cells(i, "M") = wS.Cells(c.Row, "G") '//？//
End If
End If
Next i
End With
Application.DisplayAlerts = False
wB.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　コード内の「？」の行は元データのどの列を代入していいのかわからないので
勝手に列番号を決めています。m(_ _)m

No.1 回答者： tom04 回答日時： 2017/11/10 14:09

こんにちは！

開いたブックのSheetのG・H・I・K・L・M列のデータを一致する行の同じ列に表示すれば良いのですね？
一例です。

Sub Sample1()
Dim i As Long, c As Range, wB As Workbook, wS As Worksheet
Dim myPath As String, fN As String
myPath = "C:\Users\wwsd111\Documents" & "\"
fN = "リスト.xlsx"
Application.ScreenUpdating = False
Workbooks.Open myPath & fN
Set wB = ActiveWorkbook
Set wS = wB.Worksheets(1)
With ThisWorkbook.Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
.Cells(i, "G") = wS.Cells(c.Row, "G")
.Cells(i, "I") = wS.Cells(c.Row, "I")
.Cells(i, "K") = wS.Cells(c.Row, "K")
.Cells(i, "L") = wS.Cells(c.Row, "L")
.Cells(i, "M") = wS.Cells(c.Row, "M")
End If
Next i
End With
Application.DisplayAlerts = False
wB.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じで良いのでしょうか？m(_ _)m

この回答へのお礼

ありがとうございます！
初歩的な内容に親切にご回答いただけてとても嬉しいです。

早速ためしてみたのですが、実行したところ、予想と違う結果になりました。

・Shee1のF2～M2までのデータが消えた
・G2に「登録日」というもともとM2に入力されていた単語が入った
・G列G4～G9までに11～16までの数字が入った

たびたび申し訳ないのですが、コードのどちらを修正しましたら、
Sheet1の4行目以降にリストから抽出したデータを入力することができるか
再度ご教示いただけますでしょうか？

よろしくお願いいたします。

お礼日時：2017/11/10 15:45