| |
こんなかな？
前月のデータ同一シート内で、A列＆B列の値の重複が無い物とします
今月のデータ同一シート内で、A列＆B列の値の重複が有る物とします
前月のデータはA列〜F列、今月のデータはG列〜L列とします
各表の1行目は列見出し、2行目よりデータとします
Option Explicit
'Option Compare Text
Public Sub DataMatch()
'前月のデータ列数（A列〜F列）
Const clngColumns1 As Long = 6
'所持金の列位置を指定(基準セルからの列Offset)
Const clngItems1 As Long = 3
'今月のデータ列数（G列〜L列）
Const clngColumns2 As Long = 6
'所持金の列位置を指定(基準セルからの列Offset)
Const clngItems2 As Long = 3
Dim rngList1 As Range
Dim vntList1 As Variant
Dim lngRows1 As Long
Dim lngComp1 As Long
Dim vntKeys1 As Variant
Dim vntResult1 As Variant
Dim rngList2 As Range
Dim vntList2 As Variant
Dim lngRows2 As Long
Dim lngComp2 As Long
Dim vntKeys2 As Variant
Dim vntResult2 As Variant
Dim lngMatch As Long
Dim strProm As String
'前月データシートのA1を基準とします
Set rngList1 = ActiveSheet.Range("A1")
'今月データシートのA1を基準とする
Set rngList2 = ActiveSheet.Range("G1")
'前月の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys1 = Array(1, 2)
'今月の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys2 = Array(1, 2)
'前月の比較データを保持する配列を確保
ReDim vntList1(0 To UBound(vntKeys1))
'今月の比較データを保持する配列を確保
ReDim vntList2(0 To UBound(vntKeys1))
'画面更新を停止
Application.ScreenUpdating = False
'前月の基準に就いて
If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
Else
ReDim vntResult1(1 To lngRows1, 1 To 2)
End If
'今月基準に就いて
If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
Else
ReDim vntResult2(1 To lngRows2, 1 To 2)
End If
'前月のシートの比較位置
lngComp1 = 1
'今月のシートの比較位置
lngComp2 = 1
'前月のシート若しくは、今月のシートが最終行に達するまで繰り返し
Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
'各列のデータを比較
lngMatch = DataCompare(vntList1, lngComp1, vntList2, lngComp2)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
'所持金を比較
vntResult1(lngComp1, 1) = rngList1.Offset(lngComp1, clngItems1).Value
vntResult2(lngComp2, 1) = rngList2.Offset(lngComp2, clngItems2).Value
If vntResult1(lngComp1, 1) <> vntResult2(lngComp2, 1) Then
vntResult1(lngComp1, 2) _
= vntResult2(lngComp2, 1) - vntResult1(lngComp1, 1)
vntResult2(lngComp2, 2) _
= vntResult2(lngComp2, 1) - vntResult1(lngComp1, 1)
vntResult1(lngComp1, 1) = "金額変更"
vntResult2(lngComp2, 1) = "金額変更"
Else
vntResult1(lngComp1, 1) = Empty
vntResult2(lngComp2, 1) = Empty
End If
'前月、今月のシートの比較位置を更新
lngComp1 = lngComp1 + 1
lngComp2 = lngComp2 + 1
Case Is = -1 '前月の固有値の場合
vntResult1(lngComp1, 1) = "削除"
'前月のシートの比較位置を更新
lngComp1 = lngComp1 + 1
Case Is = 1 '今月の固有値の場合
vntResult2(lngComp2, 1) = "追加"
'今月のシートの比較位置を更新
lngComp2 = lngComp2 + 1
End Select
Loop
'結果を出力
rngList1.Offset(1, clngItems1 + 1).Resize(lngRows1, 2) = vntResult1
rngList2.Offset(1, clngItems2 + 1).Resize(lngRows2, 2) = vntResult2
'前月のシートの順位を復帰
DataRestore rngList1, lngRows1, clngColumns1
'今月のシートの順位を復帰
DataRestore rngList2, lngRows2, clngColumns2
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = 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
'データをvntKeys1列で整列
For i = UBound(vntKeys) To 0 Step -1
DataSort .Offset(1).Resize(lngRows, lngColumns), .Offset(1, vntKeys(i))
Next i
'比較用配列にデータを取得
For i = 0 To UBound(vntKeys)
vntData(i) = .Offset(1, vntKeys(i)).Resize(lngRows + 1).Value
Next i
End With
GetBasicData = True
End Function
Private Sub DataRestore(rngList As Range, lngRows As Long, lngColumns As Long)
With rngList
'元データ順位を復帰
DataSort .Offset(1).Resize(lngRows, lngColumns), .Offset(1)
End With
End Sub
Private Sub DataSort(rngScope As Range, _
rngKey As Range, _
Optional lngOrientation As Long = xlTopToBottom)
rngScope.Sort _
Key1:=rngKey, Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=lngOrientation, SortMethod:=xlStroke
End Sub
Private Function DataCompare(vntKeys1 As Variant, lngPos1 As Long, _
vntKeys2 As Variant, lngPos2 As Long) As Long
' データの大小比較
Dim i As Long
Dim lngMax As Long
If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
DataCompare = 1
Exit Function
End If
If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
DataCompare = -1
Exit Function
End If
lngMax = UBound(vntKeys1, 1)
For i = 0 To lngMax
If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
Exit For
End If
Next i
If i > lngMax Then
DataCompare = 0
Else
If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
DataCompare = -1
Else
DataCompare = 1
End If
End If
End Function
|
|
Hirofumi
- 10/1/12(火) 23:49 -
