| |
こう言う事なのかな？
Option Explicit
'必ず宣言する事（しないと、比較が上手く行かない場合有り）
Option Compare Text
Public Sub DataMatch()
' データの転記
'"Sheet1"のデータ列数（A列）
Const clngColumns1 As Long = 1
'"Sheet2"のデータ列数（A列）
Const clngColumns2 As Long = 1
Dim i As Long
Dim lngCount As Long
Dim rngList1 As Range
Dim lngEnd1 As Long
Dim vntList1 As Variant
Dim lngRow1 As Long
Dim vntKeys1 As Variant
Dim lngDelete1() As Long
Dim rngList2 As Range
Dim lngEnd2 As Long
Dim vntList2 As Variant
Dim lngRow2 As Long
Dim vntKeys2 As Variant
Dim lngDelete2() As Long
Dim lngMatch As Long
Dim lngNumb() As Long
Dim strProm As String
'"Sheet1"データシートのA1を基準とします（列見出しのセル位置）
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'"Sheet2"データシートのA1を基準とする（列見出しのセル位置）
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
'画面更新を停止
Application.ScreenUpdating = False
'"Sheet1"の基準に就いて
With rngList1
'行数を取得
lngEnd1 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd1 < 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngEnd1, 1 To 1)
For i = 1 To lngEnd1
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns1) _
.Resize(lngEnd1).Value = lngNumb
'データをvntKeys1列で整列
DataSort .Offset(1).Resize(lngEnd1, _
clngColumns1 + 1), .Offset(1)
'比較用配列にデータを取得
vntList1 = .Offset(1).Resize(lngEnd1 + 1).Value
End With
'"Sheet2"基準に就いて
With rngList2
'行数を取得
lngEnd2 = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngEnd2 < 0 Then
strProm = .Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngEnd2, 1 To 1)
For i = 1 To lngEnd2
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力
.Offset(1, clngColumns2) _
.Resize(lngEnd2).Value = lngNumb
'データをvntKeys2列で整列
DataSort .Offset(1).Resize(lngEnd2, _
clngColumns2 + 1), .Offset(1)
'比較用配列にデータを取得
vntList2 = .Offset(1).Resize(lngEnd2 + 1).Value
End With
Erase lngNumb
'削除Flagの配列を確保
ReDim lngDelete1(1 To lngEnd1, 1 To 1)
ReDim lngDelete2(1 To lngEnd2, 1 To 1)
'"Sheet1"のシートの比較位置
lngRow1 = 1
'"Sheet2"のシートの比較位置
lngRow2 = 1
'"Sheet1"のシート若しくは、"Sheet2"のシートが最終行に達するまで繰り返し
Do Until lngRow1 > lngEnd1 Or lngRow2 > lngEnd2
'比較結果に就いて
Select Case vntList1(lngRow1, 1)
Case Is = vntList2(lngRow2, 1) 'Matchiした場合
'Matchしたカウントを取る
lngCount = lngCount + 1
'削除Flagを立てる
lngDelete1(lngRow1, 1) = 1
lngDelete2(lngRow2, 1) = 1
'両データの比較位置の更新
lngRow1 = lngRow1 + 1
lngRow2 = lngRow2 + 1
Case Is > vntList2(lngRow2, 1) '"Sheet2"のシート固有値の場合
'"Sheet2"のシートの比較位置を更新
lngRow2 = lngRow2 + 1
Case Is < vntList2(lngRow2, 1) '"Sheet1"のシート固有値の場合
'"Sheet1"のシートの比較位置を更新
lngRow1 = lngRow1 + 1
End Select
Loop
With rngList1
'削除Flagの配列を出力
.Offset(1, clngColumns1 + 1) _
.Resize(lngEnd1).Value = lngDelete1
'元データ順位を復帰、削除
For i = 0 To 1
DataSort .Offset(1).Resize(lngEnd1, _
clngColumns1 + 2), .Offset(1, clngColumns1 + i)
Next i
If lngCount > 0 Then
.Offset(lngEnd1 - lngCount + 1) _
.Resize(lngCount).EntireRow.Delete
End If
'復帰用Key列を削除
.Offset(, clngColumns1).Resize(, 2) _
.EntireColumn.Delete
End With
With rngList2
'削除Flagの配列を出力
.Offset(1, clngColumns2 + 1) _
.Resize(lngEnd2).Value = lngDelete2
'元データ順位を復帰、削除
For i = 0 To 1
DataSort .Offset(1).Resize(lngEnd2, _
clngColumns2 + 2), .Offset(1, clngColumns2 + i)
Next i
If lngCount > 0 Then
.Offset(lngEnd2 - lngCount + 1) _
.Resize(lngCount).EntireRow.Delete
End If
'復帰用Key列を削除
.Offset(, clngColumns2).Resize(, 2) _
.EntireColumn.Delete
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
MsgBox strProm, vbInformation
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
|
|
Hirofumi
- 06/5/27(土) 16:55 -
