VBAを使った、Excelでのシート間データ抽出

はじめまして。みなさまどうか教えてください。

Sheet１にはA列に２５０行程、コードが存在します。

Sheet2にはA列（コード）からI列まで、そして１０００行程データが存在します。

Sheet１にあるコードは重複はなく、Sheet２のコード内に必ず同じコードがあります。

Sheet２にも重複コードはありません。


そこでSheet１のコードを使い、Sheet２を検索し、同一コードのデータ（A列からI列の行すべて）を全て（２５０件分）、Sheet１のコード記載順（A1、A2、A3・・・・）で、Sheet３に抽出したいのです。

どうか、よろしくお願いします。

No.1 ベストアンサー 回答者： watabe007 回答日時： 2012/02/03 10:55

Sub Test()

Dim c As Range, i As Long
Dim myR As Variant

With Sheets("Sheet1")
For Each c In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
myR = Application.Match(c.Value, Sheets("Sheet2").Columns(1), 0)
If Not IsError(myR) Then
i = i + 1
Sheets("Sheet3").Cells(i, "A").Resize(, 9).Value = _
Sheets("Sheet2").Cells(myR, "A").Resize(, 9).Value
End If
Next
End With
End Sub

この回答へのお礼

ありがとうございました。
無事完成いたしました。

お礼日時：2012/02/03 11:57

No.4 回答者： mar00 回答日時： 2012/02/03 11:43

Sheet１にあるコードは重複はなく、Sheet２のコード内に必ず同じコードがあるという事ですが

もしSheet２にコードが無い場合、該当なしと表示します。
Sub Macro1()
Set WS01 = Sheets("Sheet1")
Set WS02 = Sheets("Sheet2")
Sheets("Sheet3").Select
Application.ScreenUpdating = False
For i = 1 To WS01.Cells(Rows.Count, 1).End(xlUp).Row
Range("A" & i) = WS01.Range("A" & i)
Range("B" & i).FormulaR1C1 = "=MATCH(RC[-1],Sheet2!C[-1],0)"
Myrow = Range("B" & i)
If Not IsError(Myrow) Then
WS02.Range("B" & Myrow & ":I" & Myrow).Copy
Range("B" & i).PasteSpecial Paste:=xlPasteValues
Else
Range("B" & i) = "該当なし"
End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。

お礼日時：2012/02/03 12:33

No.3 回答者： mu2011 回答日時： 2012/02/03 11:42

一例です。

重複したレコードは無視するようにしています。

Sub sample()
Set st1 = Worksheets("sheet1")
Set st2 = Worksheets("sheet2")
Set st3 = Worksheets("sheet3")
keys = st1.Cells(Rows.Count, "A").End(xlUp).Row
st2.Columns("A:I").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=st1.Range("A1", "A" & keys), _
CopyToRange:=st3.Range("A1"), _
Unique:=True
End Sub

この回答へのお礼

ありがとうございます

お礼日時：2012/02/03 12:34

No.2 回答者： o_chi_chi 回答日時： 2012/02/03 11:07

下記でどうでしょう。

A250、I1000、a.コード=b.コード

は環境に合うように修正のこと

でないと実行時エラー(パラメータが少なすぎます)等のエラーがでます。

あとSheet3のタイトル行は自分で修正のこと
--
Sub sSelect()
Dim strSql As String
Dim cn As Object
Dim rs As Object
Const adOpenForwardOnly = 0

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

With cn
.Provider = "MSDASQL"
.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & ThisWorkbook.FullName & "; ReadOnly=True;"
.Open
End With

strSql = "Select b.* " _
& "From " _
& " (Select * " _
& " From [Sheet1$A1:A250]) a " _
& "left join " _
& " (Select * " _
& " From [Sheet2$A1:I1000]) b " _
& " on a.コード=b.コード "

Debug.Print strSql
rs.Open strSql, cn, adOpenForwardOnly

Worksheets("Sheet3").Cells(2, 1).CopyFromRecordset rs

rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

MsgBox "Sheet3に出力しました"
End Sub

この回答へのお礼

ありがとうございました。

お礼日時：2012/02/03 11:57