| |
善く見ると、C列が時間ですね？
時間がシリアル値だと、倍精度実数の比較に成るので上手く行かない可能性が有るので
其の処理を入れたのと、小さい配列で済ます様に変更して、
少し遅く成りますが、リソースの使用量を減らしています
Option Explicit
Option Compare Text
Public Sub DataMatch3()
' 固有データのチェック(行処理版)
'Sheet1のデータ列数（A列〜E列）
Const clngColumns1 As Long = 5
'時刻の列位置(基準セル位置からの列Offset:C列)
Const clngTime1 As Long = 2
'Sheet2のデータ列数（A列〜E列）
Const clngColumns2 As Long = 5
'時刻の列位置(基準セル位置からの列Offset:C列)
Const clngTime2 As Long = 2
Dim rngList1 As Range
Dim vntData1 As Variant
Dim lngRows1 As Long
Dim lngComp1 As Long
Dim vntKeys1 As Variant
Dim rngList2 As Range
Dim vntData2 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)
'画面更新を停止
Application.ScreenUpdating = False
'Sheet1の基準に就いて
If Not GetBasicData(rngList1, lngRows1, clngColumns1, vntKeys1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'Sheet2基準に就いて
If Not GetBasicData(rngList2, lngRows2, clngColumns2, vntKeys2) 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
'比較位置がDataEndを超えた場合
If lngComp1 > lngRows1 Then
lngMatch = 1
ElseIf lngComp2 > lngRows2 Then
lngMatch = -1
Else
'比較位置の行データを取得
vntData1 = rngList1.Offset(lngComp1).Resize(, clngColumns1).Value
vntData2 = rngList2.Offset(lngComp2).Resize(, clngColumns2).Value
'★時刻のシリアル値を文字列に変換(時刻がシリアル値で無い場合、以下2行削除)
vntData1(1, clngTime1 + 1) = Format(vntData1(1, clngTime1 + 1), "hh:mm:ss")
vntData2(1, clngTime2 + 1) = Format(vntData2(1, clngTime2 + 1), "hh:mm:ss")
'各列のデータを比較
lngMatch = DataCompare(vntData1, vntKeys1, vntData2, vntKeys2)
End If
'比較結果に就いて
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)
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(rngList As Range, _
lngRows As Long, _
lngColumns As Long, _
vntKeys As Variant) As Boolean
Dim i As Long
Dim lngNumb() 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
'復帰用整列Keyを作成
ReDim lngNumb(1 To lngRows, 1 To 1)
For i = 1 To lngRows
lngNumb(i, 1) = i
Next i
'復帰用Keyの出力列を挿入
.Offset(1, lngColumns).EntireColumn.Insert
'復帰用Keyの出力
.Offset(1, lngColumns).Resize(lngRows).Value = lngNumb
'データをvntKeys1列で整列
For i = UBound(vntKeys) To 0 Step -1
DataSort .Offset(1).Resize(lngRows, lngColumns + 1), .Offset(1, vntKeys(i))
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 + 1), .Offset(1, lngColumns)
'復帰用Key列を削除
.Offset(1, lngColumns).EntireColumn.Delete
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(vntData1 As Variant, vntKeys1 As Variant, _
vntData2 As Variant, vntKeys2 As Variant) As Long
' データの大小比較
Dim i As Long
Dim lngMax As Long
'1行の最大比較回数を取得(実際は0から始まる為、回数としては+1と成る)
lngMax = UBound(vntKeys1, 1)
'1行のKeyを先頭から比較
For i = 0 To lngMax
'もし、Keyが不一致なら
If vntData1(1, vntKeys1(i) + 1) <> vntData2(1, vntKeys2(i) + 1) Then
'Forを抜ける
Exit For
End If
Next i
'Keyが全て一致した場合(Forが全て回り終った場合、iはlngMax+1と成る)
If i > lngMax Then
'戻り値の値として、「等しい」を返す
DataCompare = 0
Else
'vntKeys1の値が、vntKeys2の値因り小さい場合
If vntData1(1, vntKeys1(i) + 1) < vntData2(1, vntKeys2(i) + 1) Then
'戻り値の値として、「小さい」を返す
DataCompare = -1
Else
'戻り値の値として、「大きい」を返す
DataCompare = 1
End If
End If
End Function
|
|
Hirofumi
- 06/12/17(日) 20:38 -
