プロが教える店舗&オフィスのセキュリティ対策術

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

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

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

gooドクター

A 回答 (3件)

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



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 'ワークシート3を作成
ActiveSheet.Name = "Sheet3"
'シート1の文字列がシート2にあるか探し、あればシート2の該当行をシート3にコピー
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
    • good
    • 4

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


そのようにしてみます。


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

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


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

こんばんは!


一例です。
両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
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング