| |
Dictionary版
Option Explicit
'Option Compare Text
Public Sub DataMatch2()
'Sheet1のデータ列数（A列〜B列）
Const clngColumns1 As Long = 2
'Sheet2のデータ列数（A列〜C列）
Const clngColumns2 As Long = 3
Dim i As Long
Dim j As Long
Dim rngList1 As Range
Dim vntList As Variant
Dim lngRows As Long
Dim vntKeys As Variant
Dim rngList2 As Range
Dim vntResult As Variant
Dim lngAppend As Long
Dim dicIndex As Object
Dim vntKey As Variant
Dim strProm As String
'Sheet1データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'Sheet2データシートのA1を基準とします(先頭列見出し「社名」のセル位置)
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
'Sheetの比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys = Array(0, 1)
'Sheetの比較データを保持する配列を確保
ReDim vntList(0 To UBound(vntKeys))
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'画面更新を停止
Application.ScreenUpdating = False
'Sheet2基準に就いて
If Not GetBasicData(rngList2, lngRows, clngColumns2, vntKeys, vntList) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'結果出力用配列を確保
ReDim vntResult(1 To lngRows, 1 To 1)
'追加位置を記録
lngAppend = lngRows
'DictionaryにSheet2のデータを登録
With dicIndex
For i = 1 To lngRows
vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
If Not .Exists(vntKey) Then
.Item(vntKey) = i
End If
Next i
End With
'Sheet1の基準に就いて
If Not GetBasicData(rngList1, lngRows, clngColumns1, vntKeys, vntList) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
With dicIndex
For i = 1 To lngRows
vntKey = vntList(0)(i, 1) & vbTab & vntList(1)(i, 1)
If .Exists(vntKey) Then
vntResult(.Item(vntKey), 1) = "合致"
Else
'Sheet2の最終行にデータを追加
lngAppend = lngAppend + 1
With rngList2.Offset(lngAppend)
.Value = vntList(0)(i, 1)
.Offset(, 1).Value = vntList(1)(i, 1)
End With
End If
Next i
End With
'結果を出力
rngList2.Offset(1, clngColumns2 - 1).Resize(UBound(vntResult, 1)).Value = vntResult
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
Set dicIndex = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetBasicData(rngList As Range, _
lngRows As Long, _
lngColumns As Long, _
vntKeys As Variant, _
vntData As Variant) As Boolean
Dim i As Long
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(Rows.Count - .Row, vntKeys(0)).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows <= 0 Then
Exit Function
End If
'比較用配列にデータを取得
For i = 0 To UBound(vntKeys)
vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
Next i
End With
GetBasicData = True
End Function
|
|
Hirofumi
- 08/8/16(土) 19:10 -
