Excel VBA 2013; 並び替え、セル比較

質問

コーディングの方法を知りたいのですが、突き合わせ作業をおこないたいです。
同一列項目からなるデータを左右に並べて、左側を正として、例えば商品番号、売上日を連結するなりキーとしてマッチしたら右側の同一行に並へ
変えていきます。
そして、各行単位で比較して、差異があるセルに色付けしたいと考えています。
行数は不定です。
やり方がまったくわかりません。
サンプルを添付させていただきます。
アイデアをいただけませんでしょうか?

回答No.7

kagakusuki

少なくとも私は、
＞With .Resize(1, ListColumns).Value = .Offset(TargetRow - i).Value

や

＞With Range(FirstColumn2 & TargetRow).Resize(LastRow2 + SearchRows - TargetRow + 1, ListColumns)..Value = .Offset(1).Value

などの様に、左辺と右辺を「=」で結んでいる構文の前にWithをつけた事はこれまで一度も御座いませんし、その様な記述の仕方が成り立つとも思えません。
　ですから、そのVBAを作った方に、該当箇所でWithを付けている意図(即ち、「何のためにWithを付けているのかという事」)を御確認された方が良いと思います。

※そのVBAを作ったのは私ではないため、私に訊かれても答えようが御座いません。

補足

本来のファイルには、他にもシートがありますので、対象シートを明確にする為に任意のシート名をセットしました。
また、Withステートメントのエラー個所ですが、タイポです。
申し訳ございませんでした。
あくまでいただいたサンプルをベースにしています
再度、質問させてください。

商品番号、売上日をキーとして、6列の項目からなるもの処理ですが実際には↓11列の項目で、商品番号、枝番、売上日の3つのキー項目を
使用します。

・商品番号(A列)
・枝番(B列)
・売上日(C列)
・商品名(D列)
・金額(E列)
・仕入原価(F列)
・仕入先番号(G列)
・仕入先社名(H列)
・仕入先担当者(I列)
・仕入先住所(J列)
・備考(K列)

＊エラー個所
With .Resize(1, ListColumns)
.Value = .Offset(TargetRow - i).Value 'ここでエラーになります。
End With

＊新たに追加したキー項目(↓のmyNo2)のオフセット値を取得できていないようですが、原因がわかりません。
　教えていただけませんでしょうか?
For i = FirstRow To LastRow1
With Range(FirstColumn1 & i)
myNo1 = .Offset(, No1Column).Value
myNo2 = .Offset(, No2Column).Value '新規追加
myDate = .Offset(, DateColumn).Value
End With

↓はいただいたサンプルを改良したルーチンです。
Sub 改良版()

Const FirstRow = 3 '基準となる表において実際のデータが入力されている最初の行
Const FirstColumn1 = "A" '基準となる表において最も左端の列
Const FirstColumn2 = "M" '並べ替えを行う表において最も左端の列
Const ListColumns = 11 '表の列数
Const No1Column = 0 '表中で「商品番号が入力されている列」と「表の左端の列」との列番号の差
Const No2Column = 1 '表中で「枝番が入力されている列」と「表の左端の列」との列番号の差
Const DateColumn = 2 '表中で「売上日が入力されている列」と「表の左端の列」との列番号の差
Dim buf As Variant, m As Integer, n As Integer, i As Long, j As Long, k As Long _
, myColor As Long, LastRow1 As Long, LastRow2 As Long _
, SearchRows As Long, TargetRow As Long, myNo1 As Variant, myNo2 As Variant, myDate As Variant
myColor = RGB(146, 208, 80) 'マッチしていないデータが入っているセルを塗りつぶす色

LastRow1 = Range(FirstColumn1 & Rows.Count).End(xlUp).Row
LastRow2 = Range(FirstColumn2 & Rows.Count).End(xlUp).Row
If LastRow1 < FirstRow Or LastRow2 < FirstRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
SearchRows = LastRow2 - FirstRow + 1

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

With Range(FirstColumn2 & FirstRow).Resize(SearchRows, ListColumns)
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Resize(1, .Columns.Count).Copy
.PasteSpecial Paste:=xlPasteFormats
Intersect(.SpecialCells(xlCellTypeConstants, 23).EntireRow, .EntireColumn).Copy
Range(FirstColumn2 & LastRow2 + 1).PasteSpecial Paste:=xlPasteValues
.ClearContents
End With
SearchRows = Selection.Rows.Count
Selection.Cut Range(FirstColumn2 & LastRow1 + 1)
Application.CutCopyMode = False

For i = FirstRow To LastRow1
With Range(FirstColumn1 & i)
myNo1 = .Offset(, No1Column).Value
myNo2 = .Offset(, No2Column).Value
myDate = .Offset(, DateColumn).Value
End With
If myNo1 <> "" And myNo2 <> "" And myDate <> "" Then
If WorksheetFunction.CountIfs( _
Range(FirstColumn2 & LastRow1 + 1).Offset(, No1Column).Resize(SearchRows, 1), myNo1 _
, Range(FirstColumn2 & LastRow1 + 1).Offset(, No2Column).Resize(SearchRows, 1), myNo2 _
, Range(FirstColumn2 & LastRow1 + 1).Offset(, DateColumn).Resize(SearchRows, 1), myDate _
) > 0 Then
m = 0
For j = LastRow1 + 1 To LastRow1 + SearchRows
With Range(FirstColumn2 & j)
If .Offset(, No1Column).Value = myNo1 And .Offset(, No2Column).Value = myNo2 And .Offset(, DateColumn).Value = myDate Then
n = 0
For k = 0 To ListColumns - 1
If .Offset(, k).Value = Range(FirstColumn1 & i).Offset(, k).Value Then n = n + 1
Next k
If n > m Then
m = n
TargetRow = j
End If
End If
End With
Next j
With Range(FirstColumn2 & i)
With .Resize(1, ListColumns)
.Value = .Offset(TargetRow - i).Value
End With
With Range(FirstColumn2 & TargetRow).Resize(LastRow2 + SearchRows - TargetRow + 1, ListColumns)
.Value = .Offset(1).Value
End With
SearchRows = SearchRows - 1
For k = 0 To ListColumns - 1
If .Offset(, k).Value <> Range(FirstColumn1 & i).Offset(, k).Value Then _
.Offset(, k).Interior.Color = myColor
Next k
End With
End If
End If
If SearchRows < 1 Then Exit For
Next i

If SearchRows > 0 Then
Range(FirstColumn2 & FirstRow).Resize(1, ListColumns).Copy
With Range(FirstColumn2 & LastRow1 + 1).Resize(SearchRows, ListColumns)
.PasteSpecial Paste:=xlPasteFormats
.Interior.Color = myColor
End With
Application.CutCopyMode = False
End If

With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub