| |
コードが違いますがこんなでは？
以下を､標準モジュールに全て記述して下さい
Option Explicit
Option Compare Text
Public Sub DataMatch()
Const cstrMarkA As String = "A"
Const cstrMarkU As String = "U"
'「とらん」のデータ列数（A列〜K列）
Const clngColumns1 As Long = 11
'「記号」列位置(基準セルからの列Offset：C列)
Const clngSymbol As Long = 2
'「ますた」のデータ列数（A列〜K列）
Const clngColumns2 As Long = 11
Dim i As Long
Dim rngList1 As Range, rngList2 As Range
Dim vntList1 As Variant, vntList2 As Variant
Dim lngRows1 As Long, lngRows2 As Long
Dim lngComp1 As Long, lngComp2 As Long
Dim vntKeys1 As Variant, vntKeys2 As Variant
Dim vntData1 As Variant, vntData2 As Variant
Dim lngMatch As Long
Dim rngResult As Range
Dim lngWrite As Long
Dim strProm As String
Application.ScreenUpdating = False
'「とらん」データシートのA1を基準とします
Set rngList1 = Worksheets("とらん").Cells(1, "A")
'「ますた」データシートのA1を基準とする
Set rngList2 = Worksheets("ますた").Cells(1, "A")
'出力シートの基準位置を設定
Set rngResult = Worksheets("Sheet3").Cells(1, "A")
'「とらん」の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys1 = Array(0, 1)
'「ますた」の比較列の列挙(基準セル位置からの列Offsetを列挙)
'A列=0、C列=2、E列=4
vntKeys2 = Array(0, 1)
'「とらん」の比較データを保持する配列を確保
ReDim vntList1(0 To UBound(vntKeys1))
'「ますた」の比較データを保持する配列を確保
ReDim vntList2(0 To UBound(vntKeys1))
If Not GetBasicData(rngList1, lngRows1, _
clngColumns1, vntKeys1, vntList1) Then
strProm = rngList1.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
If Not GetBasicData(rngList2, lngRows2, _
clngColumns2, vntKeys2, vntList2) Then
strProm = rngList2.Parent.Name & "にデータが有りません"
GoTo Wayout
End If
'列見出しをSheet3にCopy
With rngResult
.Parent.Cells.Clear
.Value = "Sheet"
rngList1.Resize(, clngColumns1).Copy Destination:=.Offset(, 1)
End With
'「とらん」のシートの比較位置
lngComp1 = 1
'「ますた」のシートの比較位置
lngComp2 = 1
'「とらん」若しくは、「ますた」が最終行に達するまで繰り返し
Do Until lngComp1 > lngRows1 And lngComp2 > lngRows2
'各列のデータを比較
lngMatch = KeyCompare(vntList1, lngComp1, vntList2, lngComp2)
'比較結果に就いて
Select Case lngMatch
Case Is = 0 'Matchiした場合
'「とらん」のデータを取得
vntData1 = rngList1.Offset(lngComp1) _
.Resize(, clngColumns1).Value
'「ますた」のデータを取得
vntData2 = rngList2.Offset(lngComp2) _
.Resize(, clngColumns2).Value
With rngResult
'出力行位置を更新
lngWrite = lngWrite + 1
'「Sheet」をSheet3に出力
.Offset(lngWrite).Value = 1
'「とらん」のデータをSheet3に出力
.Offset(lngWrite, 1).Resize(, _
clngColumns1).Value = vntData1
'出力行位置を更新
lngWrite = lngWrite + 1
'「Sheet」をSheet3に出力
.Offset(lngWrite).Value = 2
'「ますた」のデータをSheet3に出力
.Offset(lngWrite, 1).Resize(, _
clngColumns2).Value = vntData2
'データの比較
For i = 4 To clngColumns1
'UnMatchなら
If vntData1(1, i) <> vntData2(1, i) Then
.Offset(lngWrite - 1, i) _
.Resize(2).Interior.Color = vbRed
End If
Next i
End With
'「とらん」のシートの比較位置を更新
lngComp1 = lngComp1 + 1
'「ますた」のシートの比較位置を更新
Do
lngComp2 = lngComp2 + 1
Loop Until KeyCompare(vntList1, lngComp1 - 1, _
vntList2, lngComp2) <> 0
Case Is = -1 '「とらん」の固有値の場合
'「とらん」のデータを取得
vntData1 = rngList1.Offset(lngComp1) _
.Resize(, clngColumns1).Value
With rngResult
'出力行位置を更新
lngWrite = lngWrite + 1
'「Sheet」をSheet3に出力
.Offset(lngWrite).Value = 1
'「とらん」のデータをSheet3に出力
.Offset(lngWrite, 1).Resize(, _
clngColumns1).Value = vntData1
'出力行位置を更新
lngWrite = lngWrite + 1
'「Sheet」をSheet3に出力
.Offset(lngWrite).Value = 2
'出力配列を確保
ReDim vntData2(1 To 2)
'「記号」列が"A"で有れば
If Trim(vntData1(1, clngSymbol + 1)) = cstrMarkA Then
For i = 1 To 2
vntData2(i) = "*"
Next i
'出力配列をSheet3に出力
With .Offset(lngWrite, 1).Resize(, 2)
.Value = vntData2
.Interior.Color = vbRed
End With
ElseIf Trim(vntData1(1, clngSymbol + 1)) = cstrMarkU Then
For i = 1 To 2
vntData2(i) = "-"
Next i
'出力配列をSheet3に出力
.Offset(lngWrite, 1).Resize(, 2).Value = vntData2
End If
End With
'「とらん」のシートの比較位置を更新
lngComp1 = lngComp1 + 1
Case Is = 1 '「ますた」の固有値の場合
'「ますた」のシートの比較位置を更新
lngComp2 = lngComp2 + 1
End Select
Loop
'「とらん」のシートの順位を復帰
DataRestore rngList1, lngRows1, clngColumns1
'「ますた」のシートの順位を復帰
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, _
vntData 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
'比較用配列にデータを取得
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 + 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 KeyCompare(vntKeys1 As Variant, lngPos1 As Long, _
vntKeys2 As Variant, lngPos2 As Long) As Long
Dim i As Long
Dim lngMax As Long
'比較位置がDataEndを超えた場合
If lngPos1 > UBound(vntKeys1(0), 1) - 1 Then
KeyCompare = 1
Exit Function
End If
If lngPos2 > UBound(vntKeys2(0), 1) - 1 Then
KeyCompare = -1
Exit Function
End If
lngMax = UBound(vntKeys1, 1)
'1行のKeyを先頭から比較
For i = 0 To lngMax
'もし、Keyが不一致なら
If vntKeys1(i)(lngPos1, 1) <> vntKeys2(i)(lngPos2, 1) Then
'Forを抜ける
Exit For
End If
Next i
If i > lngMax Then
'戻り値の値として、「等しい」を返す
KeyCompare = 0
Else
'vntKeys1の値が、vntKeys2の値因り小さい場合
If vntKeys1(i)(lngPos1, 1) < vntKeys2(i)(lngPos2, 1) Then
'戻り値の値として、「小さい」を返す
KeyCompare = -1
Else
'戻り値の値として、「大きい」を返す
KeyCompare = 1
End If
End If
End Function
|
|
Hirofumi
- 06/11/12(日) 3:07 -
