| |
WinXp等で、リソースに余裕が有るならこの方が、処理が速く成ります
Option Explicit
Option Compare Text
Public Sub DataMatch2()
' 固有データのチェック
'Sheet1のデータ列数（A列〜E列）
Const clngColumns1 As Long = 5
'Sheet2のデータ列数（A列〜E列）
Const clngColumns2 As Long = 5
Dim rngList1 As Range
Dim vntList1 As Variant
Dim lngRows1 As Long
Dim lngComp1 As Long
Dim vntKeys1 As Variant
Dim rngList2 As Range
Dim vntList2 As Variant
Dim lngRows2 As Long
Dim lngComp2 As Long
Dim vntKeys2 As Variant
Dim lngMatch As Long
Dim rngResult As Range
Dim lngCount As Long
Dim lngSort() As Long
Dim strProm As String
'Sheet1データシートのA1を基準とします
Set rngList1 = Worksheets("Sheet1").Cells(1, "A")
'Sheet2データシートのA1を基準とする
Set rngList2 = Worksheets("Sheet2").Cells(1, "A")
'出力シートの基準位置を設定
Set rngResult = Worksheets("Sheet3").Cells(1, "A")
'Sheet1の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys1 = Array(0, 1, 2, 3)
'Sheet2の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys2 = Array(0, 1, 2, 3)
'Sheet1の比較データを保持する配列を確保
ReDim vntList1(0 To UBound(vntKeys1))
'Sheet2の比較データを保持する配列を確保
ReDim vntList2(0 To UBound(vntKeys1))
'画面更新を停止
Application.ScreenUpdating = False
'Sheet1の基準に就いて
If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1, vntList1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Sheet2基準に就いて
If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2, vntList2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'抽出Flagの配列を確保
ReDim lngSort(1 To lngRows2, 1 To 1)
'Sheet1のシートの比較位置
lngComp1 = 1
'Sheet2のシートの比較位置
lngComp2 = 1
'Sheet1のシート若しくは、Sheet2のシートが最終行に達するまで繰り返し
Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
'各列のデータを比較
lngMatch = IsSame(vntList1, lngComp1, vntList2, lngComp2)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
'Sheet1のシートの比較位置を更新
lngComp1 = lngComp1 + 1
'Sheet2のシートの比較位置を更新
lngComp2 = lngComp2 + 1
Case Is = -1 'Sheet1の固有値の場合
'Sheet1のシートの比較位置を更新
lngComp1 = lngComp1 + 1
Case Is = 1 'Sheet2の固有値の場合
'抽出数をカウント
lngCount = lngCount + 1
'抽出Flagを立てる
lngSort(lngComp2, 1) = 1
'Sheet2のシートの比較位置を更新
lngComp2 = lngComp2 + 1
End Select
Loop
'Sheet1のシートの順位を復帰
DataRestore rngList1, lngRows1, clngColumns1
With rngList2
'抽出Flagを出力
.Offset(1, clngColumns2 + 1).Resize(lngRows2).Value = lngSort
'抽出FlagをKeyとして整列
DataSort .Offset(1).Resize(lngRows2, clngColumns2 + 2), .Offset(1, clngColumns2 + 1)
'データをCopy
.Offset(lngRows2 - lngCount + 1).Resize(lngCount, clngColumns2).Copy _
Destination:=rngResult.Offset(1)
'抽出Flagを削除
.Offset(1, clngColumns2 + 1).EntireColumn.Delete
End With
'Sheet2のシートの順位を復帰
DataRestore rngList2, lngRows2, clngColumns2
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList1 = Nothing
Set rngList2 = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
尚、以下のプロシージャは、前回の物と同じ物を使います
「Private Function GetBasicData」
「Private Sub DataRestore」
「Private Sub DataSort」
「Private Function IsSame」
|
|
Hirofumi
- 06/12/16(土) 6:16 -
