| |
こんな物かな？
A列、B列には、列見出しが有る物とします
結果はC列、D列に出力される物とします
Option Explicit
Public Sub DataMatch()
'「A列」のデータ列数（A列）
Const clngColumns1 As Long = 1
'「A列」の比較する列の列位置
'(基準セル位置からの列Offset：A列)
Const clngKeys1 As Long = 0
'「B列」のデータ列数（B列）
Const clngColumns2 As Long = 1
'「B列」の比較する列の列位置
'(基準セル位置からの列Offset：B列)
Const clngKeys2 As Long = 0
Dim rngList1 As Range
Dim vntList1 As Variant
Dim lngRows1 As Long
Dim lngComp1 As Long
Dim rngList2 As Range
Dim vntList2 As Variant
Dim lngRows2 As Long
Dim lngComp2 As Long
Dim lngMatch As Long
Dim rngResult As Range
Dim vntAppend As Variant
Dim lngAppend As Long
Dim vntDelete As Variant
Dim lngDelete As Long
Dim strProm As String
'「A列」のA1を基準とします(列見出しが有るとします)
Set rngList1 = ActiveSheet.Cells(1, "A")
'「B列」のB1を基準とする(列見出しが有るとします)
Set rngList2 = ActiveSheet.Cells(1, "B")
'画面更新を停止
Application.ScreenUpdating = False
'「A列」の基準に就いて
If Not GetBasicData(rngList1, lngRows1, _
clngColumns1, clngKeys1, vntList1) Then
strProm = rngList1.Value & "にデータが有りません"
GoTo Wayout
End If
'「B列」基準に就いて
If Not GetBasicData(rngList2, lngRows2, _
clngColumns2, clngKeys2, vntList2) Then
strProm = rngList2.Value & "にデータが有りません"
GoTo Wayout
End If
'「結果出力」の位置を指定します
Set rngResult = ActiveSheet.Cells(1, "C")
'出力用配列を確保します
ReDim vntAppend(lngRows2, 1 To 1), _
vntDelete(lngRows1, 1 To 1)
'列見出しを出力
vntAppend(0, 1) = "追加No．"
vntDelete(0, 1) = "削除No．"
'「A列」の比較位置
lngComp1 = 1
'「B列」の比較位置
lngComp2 = 1
'「A列」「B列」が共に最終行に達するまで繰り返し
Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
'各列のデータを比較
lngMatch = DataCompare(vntList1, _
lngComp1, vntList2, lngComp2)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
'「A列」の比較位置を更新
lngComp1 = lngComp1 + 1
'「B列」の比較位置を更新
lngComp2 = lngComp2 + 1
Case Is = -1 '「A列」の固有値の場合
'データを配列に出力
lngDelete = lngDelete + 1
vntDelete(lngDelete, 1) = vntList1(lngComp1, 1)
'「A列」のシートの比較位置を更新
lngComp1 = lngComp1 + 1
Case Is = 1 '「B列」の固有値の場合
'データを配列に出力
lngAppend = lngAppend + 1
vntAppend(lngAppend, 1) = vntList2(lngComp2, 1)
'「B列」の比較位置を更新
lngComp2 = lngComp2 + 1
End Select
Loop
'"追加No．"数、"削除No．"数で大きい方の行数分を取得します
If lngAppend > lngDelete Then
lngRows1 = lngAppend
Else
lngRows1 = lngDelete
End If
With rngResult
'出力範囲をクリア
.Resize(, 2).EntireColumn.Clear
'結果を出力
.Resize(lngRows1 + 1).Value = vntAppend
.Offset(, 1).Resize(lngRows1 + 1).Value = vntDelete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetBasicData(rngList As Range, _
lngRows As Long, _
lngColumns As Long, _
lngKeys As Long, _
vntData As Variant) As Boolean
Dim i As Long
'基準に就いて
With rngList
'行数を取得
lngRows = .Offset(.Parent.Rows.Count _
- .Row, lngKeys).End(xlUp).Row - .Row
'データが無ければFunctionを抜ける(戻り値=False)
If lngRows <= 0 Then
Exit Function
End If
'データをlngKeys列で整列
DataSort .Offset(1).Resize(lngRows, _
lngColumns), .Offset(1, lngKeys)
'比較用配列にデータを取得
vntData = .Offset(1, lngKeys) _
.Resize(lngRows + 1).Value
End With
GetBasicData = True
End Function
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
'比較位置がDataEndを超えた場合
If lngPos1 > UBound(vntKeys1, 1) - 1 Then
DataCompare = 1
Exit Function
End If
If lngPos2 > UBound(vntKeys2, 1) - 1 Then
DataCompare = -1
Exit Function
End If
'もし、Keyが不一致なら
If vntKeys1(lngPos1, 1) = vntKeys2(lngPos2, 1) Then
'戻り値の値として、「等しい」を返す
DataCompare = 0
Else
'vntKeys1の値が、vntKeys2の値因り小さい場合
If vntKeys1(lngPos1, 1) < vntKeys2(lngPos2, 1) Then
'戻り値の値として、「小さい」を返す
DataCompare = -1
Else
'戻り値の値として、「大きい」を返す
DataCompare = 1
End If
End If
End Function
|
|
Hirofumi
- 07/12/9(日) 8:57 -
