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

質問

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

回答No.4

kagakusuki

回答No.3で述べました様に不明な点が幾つかありますので、取り敢えず叩き台として以下の様な条件で処理を行うVBAを御伝えしておきます。

・もし右の表に「商品番号と売上日の両方がマッチするデータ」が存在しなかった場合には、その行は空欄にする。

・もし右の表の中に「商品番号か売上日がマッチしていないデータ」が存在していた場合には、そのデータは右の表中の「左の表の最終行」の1つ下の行から下方に向かって順番に並べる。(但し、空欄の行は削除する)

・左右の各表において「商品番号と売上日の両方が同じデータ」がどちらも複数存在する場合には、まず、左の表において「商品番号と売上日の両方が同じデータ」が存在している複数の行の内、最も上の行の所にあるデータに「商品名」～「仕入先」の各データが最もマッチしているデータを右の表中から探し出して右表の同行に配置し、
左の表において「商品番号と売上日の両方が同じデータ」が存在している複数の行の内、上から2番目以降の所にあるデータの行と同じ行の右表のセル範囲には、右表の上の行に既に配置済みとなっているデータを除外した残りのデータの中から、「商品番号と売上日の両方が同じデータ」で、尚且つ、「商品名」～「仕入先」の各データが最もマッチしているデータを探し出して右表の同行に配置する。

・もしも「商品番号と売上日の両方が同じデータ」となっている行の数が右の表の方が多い場合には、右の表の「商品番号と売上日の両方が同じデータ」の中で余ったデータは、「商品番号か売上日がマッチしていないデータ」と同様に、右の表中の「左の表の最終行」の1つ下の行から下方に向かって順番に並べる。

・もしも「商品番号と売上日の両方が同じデータ」となっている行の数が右の表の方が少ない場合には、左の表に「商品番号と売上日の両方が同じデータ」が入力されている行の右表のセル範囲に対して上から順番に、右の表の「商品番号と売上日の両方がマッチするデータ」を割り振って行き、割り当てるべきデータが不足している行に関しては空欄とする。

・右表中で、同じ行の左表のデータと差異があるデータが入っているセルを薄緑色で塗りつぶす。

Sub QNo9242735_Excel_VBA_2013_並び替え_セル比較()

Const FirstRow = 3 '基準となる表において実際のデータが入力されている最初の行
Const FirstColumn1 = "A" '基準となる表において最も左端の列
Const FirstColumn2 = "H" '並べ替えを行う表において最も左端の列
Const ListColumns = 6 '表の列数
Const NoColumn = 0 '表中で「商品番号が入力されている列」と「表の左端の列」との列番号の差
Const DateColumn = 1 '表中で「売上日が入力されている列」と「表の左端の列」との列番号の差
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, myNo 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)
myNo = .Offset(, NoColumn).Value
myDate = .Offset(, DateColumn).Value
End With
If myNo <> "" And myDate <> "" Then
If WorksheetFunction.CountIfs( _
Range(FirstColumn2 & LastRow1 + 1).Offset(, NoColumn).Resize(SearchRows, 1), myNo _
, 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(, NoColumn).Value = myNo 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

補足

ありがとうございます。
理解に時間がかかりそうです。
説明不足で申し訳ございません。
整理させていただきます。

・左の表を正とします。
・キーを商品番号と売上日として、すべてリストします。
・差異確認の色付けは右の表だけ。

＞もし右の表に「商品番号と売上日の両方がマッチするデータ」が存在しなかった場合には、その行は空欄にする。

(返答)
左の表を正として商品番号、売上日を連結したキーが右の表をマッチしない場合もございます。
左の表だけが存在する場合(右の表は空欄)、右の表だけが存在(左の表は空欄)する場合もあります。
差異確認の色付けは右の表だけにしたいので、商品番号～仕入先のすべての列に色付された行が存在します。

＞もし右の表の中に「商品番号か売上日がマッチしていないデータ」が存在していた場合には、そのデータは右の表中の「左の表の最終行」の1つ下の行から
下方に向かって順番に並べる。(但し、空欄の行は削除する)

(返答)
リストの所々で左の表だけが存在する場合(右の表は空欄)、右の表だけが存在(左の表は空欄)する場合もあります。
商品番号、売上日を連結したキー順に左右にリストしていきます。
最終行に移動はしないです。

＞左右の各表において「商品番号と売上日の両方が同じデータ」がどちらも複数存在する場合には、まず、左の表において「商品番号と売上日の両方が同じデータ」が存在している複数の行の内、最も上の行の所にあるデータに「商品名」～「仕入先」の各データが最もマッチしているデータを右の表中から探し出して右表の同行に配置し

(返答)
あくまでキーなる商品番号、売上日がマッチしたキー順に左右にリストしていきます。
「商品名」～「仕入先」は考慮しません

＞左の表において「商品番号と売上日の両方が同じデータ」が存在している複数の行の内、上から2番目以降の所にあるデータの行と同じ行の右表のセル範囲には、右表の上の行に既に配置済みとなっているデータを除外した残りのデータの中から、「商品番号と売上日の両方が同じデータ」で、尚且つ、「商品名」～「仕入先」の各データが最もマッチしているデータを探し出して右表の同行に配置する。

(返答)
あくまでキーなる商品番号、売上日がマッチしたキー順に左右にリストしていきます。
「商品名」～「仕入先」は考慮しません

＞もしも「商品番号と売上日の両方が同じデータ」となっている行の数が右の表の方が多い場合には、右の表の「商品番号と売上日の両方が同じデータ」の中で余ったデータは、「商品番号か売上日がマッチしていないデータ」と同様に、右の表中の「左の表の最終行」の1つ下の行から下方に向かって順番に並べる。

(返答)
リストの所々で左の表だけが存在する場合(右の表は空欄)、右の表だけが存在(左の表は空欄)する場合もあります。
商品番号、売上日を連結したキー順に左右にリストしていきます。
最終行に移動はしないです。

＞もしも「商品番号と売上日の両方が同じデータ」となっている行の数が右の表の方が少ない場合には、左の表に「商品番号と売上日の両方が同じデータ」が入力されている行の右表のセル範囲に対して上から順番に、右の表の「商品番号と売上日の両方がマッチするデータ」を割り振って行き、割り当てるべきデータが不足している行に関しては空欄とする。

(返答)
リストの所々で左の表だけが存在する場合(右の表は空欄)、右の表だけが存在(左の表は空欄)する場合もあります。
商品番号、売上日を連結したキー順に左右にリストしていきます。
最終行に移動はしないです。