全シート内の差分比較とそのセル色塗りつぶしマクロ

質問

Excelファイルデータの差分比較とそのセル塗りつぶしのマクロを作成したいのですが、今の自分には、下記のマクロでとどまっており、
マクロを実行するファイル内シートにデータをコピーしたり、
マクロ内でその都度、シート名の記載の変更、差分比較データ範囲の変更が必要になり、大変不便で困っております。

やりたい事は、マクロでユーザがExcelのファイルを選択出来て、
そのファイルの中の全シートのデータについて、差分比較とそのそのセルの塗りつぶしをして、塗りつぶしをファイルへ反映させて保存させることです。
どうか、お分かりの方がいらっしゃいましたら、ご教示をお願い出来ますと大変助かります。

各シート内のデータは、列、行共にほぼ同じフォーマットで値が入っています。
それらのシート内のデータで修正した箇所を見つける為、差分比較がしたいです。
例えば、シートが3つの場合は、
1つ目のシートは修正前のデータ、
2つ目のシート内は1つ目のシートの値を部分的に修正したものです。
3つ目のシート内のデータも、1つ目のデータの値を更に再修正したものです。
この3つのシート内のデータを差分比較したいです。
シートの数は、選択したファイルによって異なります。

Sub TEST1()

Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用
Set s1 = Worksheets("修正前S装置検索システム") '比較元シート名
Set s2 = Worksheets("修正後装置検索システム") '比較先シート名

Dim arr1 As Variant, arr2 As Variant

arr1 = s1.Range("$A$2:$W$548").Value
arr2 = s2.Range("$A$2:$W$548").Value

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> arr2(i, j) Then
'塗りつぶし処理
s1.Cells(i + 1, j).Interior.Color = RGB(255, 0, 0)
s2.Cells(i + 1, j).Interior.Color = RGB(102, 255, 51)
End If
Next
Next

End Sub

回答No.6

kkkkkm

> 【チェック済】の記載を入力ファイル名の前へ追加した出力ファイル名で出す事は可能でしょうか？

'Workbooks(FileName).Save
のところを
Wb.SaveAs Left(FullPath, InStrRev(FullPath, "\")) & "【チェック済】" & FileName
に変更すれば可能です。

> また、チェックするセル範囲を"$A$2:$W$548"と指定していますが、範囲はデータが入っているセル領域とする事はかのうでしょうか？修正で行が増える事があります。

A2からが範囲だとして

'arr1 = s1.Range("$A$2:$W$548").Value
を
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells.SpecialCells(xlCellTypeLastCell)).Value
に

'arr2 = s2.Range("$A$2:$W$548").Value
を
arr2 = s2.Range(s2.Range("$A$2"), s2.Cells.SpecialCells(xlCellTypeLastCell)).Value
に変更してください。

あと、色をシート毎に変更したい場合は計算で色を変更することも可能だと思いますが、その場合好みの色にならない可能性もあります。
変更する可能性がある回数をある程度決めておいて、たとえば10回まではないだろうという場合10回までの色を最初から決めておいてマクロを実行するブックの利用しないセルをその色で色見本的に塗りつぶしておきます。

マクロを実行するブックのSheet1のA1からA10までを好みの色であらかじめ塗りつぶしておき
以下コードを実行すると差分比較してシート毎にセルの色とタブの色を色見本の上から順に設定していき、色見本のセルにその色がどのシートで使われたのか分かるようにシート名を記載していきます。
タブの色と色見本のシート名はどちらかだけでいいとは思いますが、タブの色は変更できないとかあれば色見本のシート名もあったら二つのブックをちょっとずらして見れば便利かなと思ったりします。

と余計なお世話をしてみたコードです。

元のコードの状態を保ったまま変更しています。

Sub Test2()
Dim Wb As Workbook
Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用
Dim i As Long, j As Long, sCount As Long, k As Long
Dim arr1 As Variant, arr2 As Variant
Dim FullPath As Variant, FileName As String
Dim mRow As Long, mCol As Long
Dim mRng As Range
Dim mColor() As Variant

FullPath = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
If FullPath = False Then
Exit Sub
End If

'色見本のセルから色の取得
k = 0
For Each mRng In ThisWorkbook.Sheets("Sheet1").Range("A1:A10")
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = ""
ReDim Preserve mColor(k)
mColor(k) = mRng.Interior.Color
k = k + 1
Next

Workbooks.Open FullPath
FileName = Mid(FullPath, InStrRev(FullPath, "\") + 1)

Set Wb = Workbooks(FileName)
Set s1 = Wb.Worksheets(1) '比較元シート

'arr1 = s1.Range("$A$2:$W$548").Value
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells.SpecialCells(xlCellTypeLastCell)).Value

k = 0

For sCount = 2 To Wb.Sheets.Count

Set s2 = Wb.Worksheets(sCount) '比較先シート

'arr2 = s2.Range("$A$2:$W$548").Value
arr2 = s2.Range(s2.Range("$A$2"), s2.Cells.SpecialCells(xlCellTypeLastCell)).Value

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> arr2(i, j) Then
'塗りつぶし処理
's1.Cells(i + 1, j).Interior.Color = RGB(255, 0, 0)
s1.Cells(i + 1, j).Interior.Color = mColor(k)
's2.Cells(i + 1, j).Interior.Color = RGB(102, 255, 51)
s2.Cells(i + 1, j).Interior.Color = mColor(k)
'タブの色を塗りつぶしと同じ色に変更
s2.Tab.Color = mColor(k)
End If
Next
Next
'色見本のセルにシート名を記述
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = s2.Name

Set s2 = Nothing
k = k + 1
Next

'Workbooks(FileName).Save
Wb.SaveAs Left(FullPath, InStrRev(FullPath, "\")) & "【チェック済】" & FileName

Set s1 = Nothing
Set Wb = Nothing

End Sub