VBAで検索して、行をコピー＆追加したい

Excel2010で以下のことをしたいのですが、VBAがあまりできないのでやれません。
どうか助けてください。

・sheet1のA列に検索用の番号（例として商品番号）が入力されています。
・sheet2はデータベースで、A列に商品番号B列に商品名、C列に国名、D列に価格・・～その後J列まで情報が入っています。（行数は1万行）
・sheet1に入っている商品番号でデータベースから行をピックアップし、該当の行をsheet1のB列以降にコピーしたいのです。
（シート3を新しく作っても構いません。やりやすい方で）
・ただし、同じ商品番号で複数の行がヒットしますので、複数の行がヒットしたら行を追加しながら、行をコピーしたいです。

どのように書いたら良いか参考になるURLだけでもご教授ください。
よろしくお願いします。

No.3 ベストアンサー 回答者： over_the_galaxy 回答日時： 2014/03/11 00:12

もう回答が付いてますね、でもせっかく書いたのだからあげときます（笑）

Sub main()

Dim i1 As Long, i2 As Long, i3 As Long
Dim LastRow1 As Long, LastRow2 As Long

'各シートのデータの最終行を取得
LastRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LastRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
i3 = 1

Worksheets.Add 'ワークシート３を作成
ActiveSheet.Name = "Sheet3"
'シート１の文字列がシート２にあるか探し、あればシート２の該当行をシート３にコピー
For i1 = 1 To LastRow1
For i2 = 1 To LastRow2
If Worksheets("Sheet2").Cells(i2, 1) = Worksheets("Sheet1").Cells(i1, 1) Then
Worksheets("Sheet2").Cells(i2, 1).EntireRow.Copy Destination:=Worksheets("Sheet3").Rows(i3)
i3 = i3 + 1
End If
Next i2
Next i1

End Sub

No.2 回答者： keithin 回答日時： 2014/03/10 23:05

＞複数の行がヒットしたら行を追加しながら、行をコピーしたいです。

そのようにしてみます。


マクロはふつーに検索してコピーするだけの、ＶＢＡのヘルプに出てくる基本的な使用例をほぼそのまま利用してみます。

sub macro1()
　dim r as long
　dim c as range
　dim c0 as string

　worksheets("Sheet1").select

　for r = range("A65536").end(xlup).row to 1 step -1
　　set c = worksheets("Sheet2").range("A:A").find(what:=cells(r, "A").value, lookin:=xlvalues, lookat:=xlwhole)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　c.entirerow.copy
　　　　cells(r, "A").offset(1).insert
　　　　set c = worksheets("Sheet2").range("A:A").findnext(c)
　　　loop until c.address = c0
　　　cells(r, "A").entirerow.delete shift:=xlshiftup
　　end if
　next r
end sub


実際にあなたがヤリタイ事に応じて、自力で適切に応用してご利用ください。

No.1 回答者： tom04 回答日時： 2014/03/10 23:04

こんばんは！

一例です。
両Sheetとも1行目は項目行で、データは2行目以降にあるとします。

標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
wS.Range("A1").AutoFilter field:=1, Criteria1:=.Cells(i, "A")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow, "J")).Copy .Cells(Rows.Count, "B").End(xlUp).Offset(1)
End If
Next i
wS.AutoFilterMode = False
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(2, "A"), .Cells(lastRow, "A")).Delete shift:=xlToLeft
For i = lastRow To 2 Step -1
If WorksheetFunction.CountIf(.Range("A:A"), .Cells(i, "A")) > 1 Then
.Cells(i, "A").ClearContents
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m