Excel VBA で二つのシートを比較抽出

質問

Excel VBA で二つのシートを比較して合致するレコードを別のシートに抽出する方法について
下記ホームページのコードを利用させていただきました。
https://okwave.jp/qa/q5917011.html

●fax2シート B列(検索順)
　セル1　A
　　　2　B
　　　3　D
　　　4　C

●fax3シート( 比較抽出結果)
　セル1　A
　　　2　B
　　　3　C
　　　4　D

比較抽出結果が検索順にするにはどのようにコードを記述すればよいか教えていただけますか。

回答No.13

kkkkkm · ベストアンサー

色(書式)のコピーは

変数宣言の後に

Worksheets("Fax3").Cells.Clear

を追加して

'セル幅自動調整
の前に

Worksheets("Fax1").Range("A1").copy
Worksheets("Fax3").Range("A1:Z1").PasteSpecial Paste:=xlPasteFormats
Worksheets("Fax1").Range("A2").copy
Worksheets("Fax3").Range(Cells(2, "A"), Cells(n - 1, "Z")).PasteSpecial Paste:=xlPasteFormats

を追加してみてください。

お礼

セルの色についてもできることが
できました。
いろいろとご教示いただき有り難う
ございました。
コードの記述内容については
今後の為に自分で調べていきます。

回答No.12

kkkkkm

> ●fax1シートのセルは塗るつぶしされています。
> 　fax3シートに書き出す際に塗るつぶしも
> 　できないでしょうか。

全て同じ色で塗りつぶされているのでしょうか。
パターンが分かりません。状況によっては動作がかなり遅くなります。

> ●1行ごとにコードの説明を記載して
> 　いただけないでしょうか。

甘えすぎです。簡単な動作の説明は入れてあります。
そんなトリッキーな事はしていませんので、ご自身で調べてください。

回答No.11

kkkkkm

No10の追記です。

'重複して抽出された場合、fax3への出力が5000行を超える可能性がある場合はこちらで
'可能性がない場合でもこちらでいけます。
'fax2のB列データがfax1のB列に重複しない(させない)場合はExit Forを有効にしてください。

Public Sub TestcopyTranspose()

Dim mfax1 As Variant, mFax1Row As Long, mFax1Column As Long
Dim mfax2 As Variant, mFax2Row As Long
Dim mfax3 As Variant
Dim i As Long, j As Long, k As Long, n As Long

'fax1データ範囲を配列変数に取り込み
mfax1 = Worksheets("Fax1").Range("A1:Z5000").Value
'fax2データ範囲を配列変数に取り込み
mfax2 = Worksheets("Fax2").Range("A1:B500").Value

ReDim tmp(1 To UBound(mfax1), 1 To UBound(mfax1, 2))
ReDim mfax3(1 To UBound(mfax1, 2), 1 To 2)
mFax1Column = UBound(mfax1, 2)
mFax1Row = UBound(mfax1)
mFax2Row = UBound(mfax2)

'見出し
For k = 1 To mFax1Column
mfax3(k, 1) = mfax1(1, k)
Next k
'比較開始 Fa2の位置関係のまま取り出し
n = 2
For i = 2 To mFax2Row
For j = 2 To mFax1Row
If mfax2(i, 2) = mfax1(j, 2) And mfax2(i, 2) <> "" Then
For k = 1 To mFax1Column
mfax3(k, n) = mfax1(j, k)
Next k
n = n + 1
ReDim Preserve mfax3(1 To UBound(mfax1, 2), 1 To n)
'Exit For 'fax2のB列データがfax1のB列に重複しない(させない)場合はこれをコメントから外して
End If
Next j
Next i
'データ書き出し
With Sheets("fax3")
.Range("A1").Resize(UBound(mfax3, 2), UBound(mfax3)) = WorksheetFunction.Transpose(mfax3)
End With

Worksheets("Fax3").Activate

'比較終了

'セル幅自動調整
Worksheets("fax3").Range("a:g").Columns.AutoFit
Worksheets("fax3").Activate
End Sub

回答No.10

kkkkkm

No6で頂いた補足より引き続き
fax2のB列のデータがfax1のB列にあればfax1のその行のAからZまでのデータをfax3にfax2の順番で転記する
とうことでいいのでしょうか、以下で試してみてください。

Public Sub Testcopy3()

Dim mfax1 As Variant, mFax1Row As Long, mFax1Column As Long
Dim mfax2 As Variant, mFax2Row As Long
Dim mfax3 As Variant
Dim i As Long, j As Long, k As Long, n As Long

'fax1データ範囲を配列変数に取り込み
mfax1 = Worksheets("Fax1").Range("A1:Z5000").Value
'fax2データ範囲を配列変数に取り込み
mfax2 = Worksheets("Fax2").Range("A1:B500").Value

ReDim tmp(1 To UBound(mfax1), 1 To UBound(mfax1, 2))
ReDim mfax3(1 To UBound(mfax2), 1 To UBound(mfax1, 2))
mFax1Column = UBound(mfax1, 2)
mFax1Row = UBound(mfax1)
mFax2Row = UBound(mfax2)

'見出し
For k = 1 To mFax1Column
mfax3(1, k) = mfax1(1, k)
Next k
'比較開始 Fa2の位置関係のまま取り出し
n = 2
For i = 2 To mFax2Row
For j = 2 To mFax1Row
If mfax2(i, 2) = mfax1(j, 2) And mfax2(i, 2) <> "" Then
For k = 1 To mFax1Column
mfax3(n, k) = mfax1(j, k)
Next k
n = n + 1
Exit For 'fax2のB列データがfax1のB列に複数ある場合はこれをコメントに
End If
Next j
Next i
'データ書き出し
With Sheets("fax3")
.Range("A1").Resize(UBound(mfax3), mFax1Column) = mfax3
End With

Worksheets("Fax3").Activate

'比較終了

'セル幅自動調整
Worksheets("fax3").Range("a:g").Columns.AutoFit
Worksheets("fax3").Activate
End Sub

補足

速やかな回答有難う御座います。
意図していることが出来ました。
申し訳ありませんが、あと２つ要望が
あります。
●fax1シートのセルは塗るつぶしされています。
　fax3シートに書き出す際に塗るつぶしも
　できないでしょうか。

●1行ごとにコードの説明を記載して
　いただけないでしょうか。

勝手なお願いばかりで申し訳ありません。

回答No.9

HohoPapa

#3です。
もし、
抽出するときに重複を含めるのであれば、
　SQL = SQL & "group BY [F1]" & vbCrLf
↑の行をコメントアウトしてください。

回答No.8

kkkkkm

No4を試す場合以下のように変更してください。

空白が無いとエラーになるのを忘れてました。

With Worksheets("Fax3")
.Range(.Cells(1, "A"), .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

のところを

Dim mRange As Range

With Worksheets("Fax3")
Set mRange = .Range(.Cells(1, "A"), .Cells(Rows.Count, "A").End(xlUp))
If WorksheetFunction.CountBlank(mRange) > 0 Then
mRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
End With
Set mRange = Nothing

回答No.7

kkkkkm

No6の訂正です
もとのコメントをそのままにしましたが、今回の場合は
'fax1範囲指定
'fax2範囲指定
は、それぞれ
'fax1データ範囲を配列変数に取り込み
'fax2エータ範囲を配列変数に取り込み
が適切でした。

回答No.6

kkkkkm

No1もNo4も元のコードを再利用しましたが、遅い場合は以下で試してみてください。
No1もNo4もFax1のA列のデータをFax2のC列のデータから探しています。
(元のコードがそれっぽかったので)

Public Sub Testcopy()

Dim mfax1 As Variant, mFax1Row As Long, mFax1Columns As Long
Dim mfax2 As Variant, mFax2Row As Long, mFax2Columns As Long
Dim mfax3 As Variant, mFax3Row As Long
Dim mtmp As Variant
Dim i As Long, j As Long, k As Long

'fax1範囲指定
mfax1 = Worksheets("Fax1").Range("A1").CurrentRegion.Value
'fax2範囲指定
mfax2 = Worksheets("Fax2").Range("A1").CurrentRegion.Value

ReDim tmp(1 To UBound(mfax2), 1 To UBound(mfax1, 2))
ReDim mfax3(1 To UBound(mfax2), 1 To UBound(mfax1, 2))
mFax1Columns = UBound(mfax1, 2)
mFax2Columns = UBound(mfax2, 2)
mFax1Row = UBound(mfax1)
mFax2Row = UBound(mfax2)
mFax3Row = mFax2Row

'見出し
For k = 1 To mFax1Columns
tmp(1, k) = mfax1(1, k)
Next k
'比較開始 Fa2の位置関係のまま取り出し
For i = 1 To mFax1Row
For j = 1 To mFax2Row
If mfax1(i, 1) = mfax2(j, 3) And mfax1(i, 1) <> "" Then
For k = 1 To mFax1Columns
tmp(j, k) = mfax1(i, k)
Next k
End If
Next j
Next i
j = 1
'途中の空白データを省く
For i = 1 To mFax3Row
If tmp(i, 1) <> "" Then
For k = 1 To mFax1Columns
mfax3(j, k) = tmp(i, k)
Next k
j = j + 1
End If
Next i
'データ書き出し
With Sheets("fax3")
.Range("A1").Resize(UBound(mfax3), mFax1Columns) = mfax3
End With

Worksheets("Fax3").Activate

'比較終了

'セル幅自動調整
Worksheets("fax3").Range("a:g").Columns.AutoFit
Worksheets("fax3").Activate
End Sub Worksheets("fax3").Range("a:g").Columns.AutoFit
Worksheets("fax3").Activate
End Sub

補足

回答有難う御座います。

質問内容に足らない点がありましたので
補足致します。

●fax1シート(検索対象データ)
　➢1行目は見出し(列A～Z)
　　2行目からはデータが記載
　➢検索対象はB列 2行目～5,000行目

●fax2シート(検索を行おうとしているデータ)
　➢1行目は見出し(列A～B)
➢検索を行おうとしているデータは
　　B列 2行目～500行目になります。

●fax3シート( 比較抽出結果)
　➢1行目はfax1シートと同じ見出し
　➢fax1シート B列の中にfax2シート B列と
　　同じデータがある場合はfax3シートに
　　書き出す。

殆ど知識がなくうまく質問が出来なくて
申し訳ありません。

回答No.5

SI299792

前の怪盗に「かなり遅くなる」と書いてあったので、早くできる方法です。
10000 件１秒でできます。
コピー領域は、前質問と同じ、Ａ～Ｇ列としました。
「セル1　A」と書いてあったのでヘッダー無し、１行目からいきなりデータとしました。
Option Explicit
'
Sub Macro1()
　　Dim Dictionary As Object
　　Dim I As Worksheet
　　Dim RInp As Long
　　Dim ROut As Long
　　Dim Key As String
'
　　Set Dictionary = CreateObject("Scripting.Dictionary")
　　Set I = Sheets("fax1")
'
　　For RInp = 1 To I.Cells(Rows.Count, "B").End(xlUp).Row
　　　　Key = I.Cells(RInp, "B")
　　　　Dictionary(Key) = ""
　　Next RInp
'
　　Set I = Sheets("fax2")
　　Sheets("fax3").Select
　　[A:G].ClearContents
　　Application.ScreenUpdating = False
'
　　For RInp = 1 To I.Cells(Rows.Count, "B").End(xlUp).Row
　　　　Key = I.Cells(RInp, "B")
'
　　　　If Dictionary.Exists(Key) Then
　　　　　　[A1:G1].Offset(ROut) = I.[A1:G1].Offset(RInp - 1).Value
　　　　　　ROut = ROut + 1
　　　　End If
　　Next RInp
End Sub

回答No.4

kkkkkm

fax2シートで見つかった順番ではなくfax2シートにある元の順番通りでしたら以下で試してみてください。

Dim FoundCell As Range
Dim i As Long

For i = 1 To fax1Table.Rows.Count
Set FoundCell = fax2Table.Columns(3).Find(fax1Table(i, 1).Value, , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
fax1Table(i, 1).Resize(1, 3).copy dst.Offset(FoundCell.Row - 1)
End If

Next i
With Worksheets("Fax3")
.Range(.Cells(1, "A"), .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)). _
SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With

また
No1の
fax1Table.Offset(i - 1).copy dst
は
fax1Table(i, 1).Resize(1, 3).copy dst
の間違いでした。

回答No.3

HohoPapa

求めている内容を私が理解しているか疑問はありますが、
以下でいかがでしょうか

Option Explicit

Sub MyPicup()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim PicData As String
　Dim Rowcnt As Long

　'抽出条件を組み立て
　With ThisWorkbook.Sheets("fax1")
　　Rowcnt = 1
　　PicData = "'" & .Cells(1, 1).Value & "'" & vbCrLf
　　Do
　　　If .Cells(Rowcnt, 1).Value = "" Then Exit Do
　　　PicData = PicData & "," & "'" & .Cells(Rowcnt, 1).Value & "'" & vbCrLf
　　　Rowcnt = Rowcnt + 1
　　Loop
　End With

　'SQL全文を組み立て
　SQL = "SELECT F1" & vbCrLf
　SQL = SQL & "FROM [" & "fax2" & "$C1:C50000]" & vbCrLf
　SQL = SQL & "WHERE F1 IN(" & PicData & ")" & vbCrLf
　SQL = SQL & "group BY [F1]" & vbCrLf

　'DB定義とSQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=No;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name
　rs.Open SQL, cn

　'出力先をクリアーして結果セットを出力
　With ThisWorkbook.Sheets("fax3")
　　.Cells.ClearContents
　　.Cells(1, 1).CopyFromRecordset rs
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub