|
Sheet1、Sheet2共に列見出しが在る物とします
Option Explicit
Public Sub DataMatch3()
' 同一データのチェック
' Dictionary版
'Sheet1のデータ列数(A列)
Const clngColumns1 As Long = 1
'Sheet1のKey列(A列)の位置設定(基準位置からの列Offset)
Const clngKey1 As Long = 0
'Sheet2のデータ列数(A列〜B列)
Const clngColumns2 As Long = 2
'Sheet2のKey列(A列)の位置設定(基準位置からの列Offset)
Const clngKey2 As Long = 0
Dim i As Long
Dim rngList1 As Range
Dim lngRows1 As Long
Dim vntKeys1 As Variant
Dim rngList2 As Range
Dim lngRows2 As Long
Dim vntKeys2 As Variant
Dim rngResult As Range
Dim lngWrite As Long
Dim dicIndex As Object
Dim strProm As String
'Sheet1データシートのA1を基準とします
Set rngList1 = Worksheets("Sheet1").Range("A1")
'Sheet2データシートのA1を基準とする
Set rngList2 = Worksheets("Sheet2").Range("A1")
'Sheet3結果シートのA1を基準とする
Set rngResult = Worksheets("Sheet3").Range("A1")
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'画面更新を停止
Application.ScreenUpdating = False
'Sheet1の基準に就いて、Key列データと行数取得
If Not GetBasicData(rngList1, lngRows1, clngKey1, vntKeys1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Sheet2の基準に就いて、Key列データと行数取得
If Not GetBasicData(rngList2, lngRows2, clngKey2, vntKeys2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Sheet2のKeyデータと行位置をDictionaryに登録
With dicIndex
'最終行に達するまで繰り返し
For i = 1 To lngRows2
'Dictionaryに登録
.Item(vntKeys2(i, 1)) = i
Next i
'Sheet1のKeyデータをDictionaryで比較し在ったら転記
For i = 1 To lngRows1
'Dictionaryに登録が有る場合集計
If .Exists(vntKeys1(i, 1)) Then
'出力位置を更新
lngWrite = lngWrite + 1
'Sheet3のA列にSheet2シートの該当行を出力
rngList2.Offset(.Item(vntKeys1(i, 1))).Resize(, clngColumns2).Copy _
Destination:=rngResult.Offset(lngWrite)
End If
Next i
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set dicIndex = Nothing
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetBasicData(rngList As Range, _
lngRows As Long, _
lngKeys As Long, _
vntData As Variant) As Boolean
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(Rows.Count - .Row, lngKeys).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows <= 0 Then
Exit Function
End If
'比較用配列にデータを取得
vntData = .Offset(1, lngKeys).Resize(lngRows + 1).Value
End With
GetBasicData = True
End Function
|
|