| |
ついでに、突き合わせ処理の速度向上版（Dictionary仕様）もUpします
行削除のマクロと同じ標準モジュールに入れて下さい
Public Sub CompareData()
' 突き合わせ処理（Dictionary使用）
'前月のデータ列数（A列〜K列）
Const clngColumns1 As Long = 11
'今月のデータ列数（M列〜W列）
Const clngColumns2 As Long = 11
Dim rngList1 As Range
Dim rngList2 As Range
Dim strProm As String
'前月データシートのA1を基準とします
Set rngList1 = ActiveSheet.Range("A1")
'今月データシートのA1を基準とする
Set rngList2 = ActiveSheet.Range("M1")
'画面更新を停止
Application.ScreenUpdating = False
strProm = DataMatch(rngList1, clngColumns1, rngList2, clngColumns2)
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
End Sub
' Listの突き合わせ
'
' rngList1：前月List先頭セル位置（見出し位置）
' lngColumns1：Listの列数
' rngList2：当月List先頭セル位置（見出し位置）
' lngColumns2：Listの列数
'
' 戻り値：処理コメント
'
Private Function DataMatch(rngList1 As Range, lngColumns1 As Long, _
rngList2 As Range, lngColumns2 As Long) As String
'受注額の列位置を指定(基準セルからの列Offset)
Const clngItems1 As Long = 7 '★？？？
'差異の列位置を指定(基準セルからの列Offset)
Const clngDiffer1 As Long = 9 '★？？？
'受注額の列位置を指定(基準セルからの列Offset)
Const clngItems2 As Long = 7
'差異の列位置を指定(基準セルからの列Offset)
Const clngDiffer2 As Long = 9
Dim i As Long
Dim j As Long
Dim lngPos As Long
Dim lngRows1 As Long
Dim vntKeys1 As Variant
Dim vntResult1 As Variant
Dim vntTmp1 As Variant
Dim lngRows2 As Long
Dim vntKeys2 As Variant
Dim vntResult2 As Variant
Dim vntTmp2 As Variant
Dim vntKey As Variant
Dim vntList As Variant
Dim dicIndex As Object
Dim blnCheck() As Boolean
'前月データシートのA1を基準とします
Set rngList1 = ActiveSheet.Range("A1")
'今月データシートのA1を基準とする
Set rngList2 = ActiveSheet.Range("M1")
'前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys1 = Array(2, 3) '★？？？
'今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
'M列=0、O列=2、Q列=4
vntKeys2 = Array(2, 3)
'比較データを保持する配列を確保
ReDim vntList(UBound(vntKeys1))
'Dictionaryオブジェクトを取得
Set dicIndex = CreateObject("Scripting.Dictionary")
'今月基準に就いて
If Not GetBasicData(rngList2, lngRows2, lngColumns2, vntKeys2, vntList) Then
DataMatch = "今月にデータが有りません"
GoTo Wayout
Else
ReDim vntResult2(1 To lngRows2, 1 To 2)
End If
'Dictionaryオブジェクトに当月のKeyを登録
With dicIndex
For i = 1 To lngRows2
vntKey = vntList(0)(i, 1)
For j = 1 To UBound(vntList)
vntKey = vntKey & vbTab & vntList(j)(i, 1)
Next j
.Item(vntKey) = i
Next i
End With
ReDim blnCheck(1 To lngRows2)
'前月の基準に就いて
If Not GetBasicData(rngList1, lngRows1, lngColumns1, vntKeys1, vntList) Then
DataMatch = "前月にデータが有りません"
GoTo Wayout
Else
ReDim vntResult1(1 To lngRows1, 1 To 2)
End If
'当月データの先頭から最終まで繰り返し
For i = 1 To lngRows1
'Keyの作成
vntKey = vntList(0)(i, 1)
For j = 1 To UBound(vntList)
vntKey = vntKey & vbTab & vntList(j)(i, 1)
Next j
'DictionaryにKeyがあるなら
If dicIndex.Exists(vntKey) Then
'当月の行位置を取得
lngPos = dicIndex.Item(vntKey)
'所持金を比較
vntTmp1 = rngList1.Offset(i, clngItems1).Value
vntTmp2 = rngList2.Offset(lngPos, clngItems2).Value
If vntTmp1 <> vntTmp2 Then
vntResult1(i, 1) = "金額変更"
vntResult1(i, 2) = vntTmp2 - vntTmp1
vntResult2(lngPos, 1) = "金額変更"
vntResult2(lngPos, 2) = vntTmp2 - vntTmp1
End If
'チェックを入れる
blnCheck(lngPos) = True
Else
vntResult1(i, 1) = "削除"
End If
Next i
'今月のシートに追加を記入
For i = 1 To lngRows2
If Not blnCheck(i) Then
vntResult2(i, 1) = "追加"
End If
Next i
'結果を出力
rngList1.Offset(1, clngDiffer1).Resize(lngRows1, 2) = vntResult1
rngList2.Offset(1, clngDiffer2).Resize(lngRows2, 2) = vntResult2
DataMatch = "突き合わせ処理が完了しました"
Wayout:
Set dicIndex = Nothing
End Function
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
- 10/1/15(金) 13:13 -
