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

質問

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.17

kkkkkm · ベストアンサー

> 出力ファイルのシート1(修正前データ)で塗りつぶしセル(修正後の差分部分)のフォントの色を黒字から白色の文字へ変更するコード

修正前データのシートだけでしたら

s1.Cells(i + 1, j).Interior.Color = mColor(k)

が2か所ありますのでそこに文字色を白にするコードを追加します

s1.Cells(i + 1, j).Interior.Color = mColor(k)
s1.Cells(i + 1, j).Font.Color = vbWhite '←これを追加

テストしていて思ったのですが

比較先シートを選択した時点で選択したタブの色が分からなくなって、たとえば4回目以降くらいになると過去の色が混在していた場合、その回に変更した色が何なのかが即わからない感じがしました。

そこで、1行目は修正対象ではないので差分で色が変わらないと思いますから、比較先シートの1行目のセルの色をタブの色と同じ色にして、ウィンドウ枠の固定で1行目をスクロールしないようにしておけば分かりやすい気もします。

ただし、既に1行目に色がついていたりウィンドウ枠の固定をしていた場合は設定が変更されてしまいます。

利用する場合は

最後の方で

'色見本のセルにシート名を記述
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = s2.Name

Set s2 = Nothing
Set sP = Nothing
If k = 9 Then

となっている間に入れる感じでコードを追加してください。

'色見本のセルにシート名を記述
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = s2.Name

'-------ここから
'1行目のセルの色をタブの色と同じ色にして、ウィンドウ枠の固定
s2.Activate
s2.Range("A2").Select
ActiveWindow.FreezePanes = False
ActiveWindow.FreezePanes = True
s2.Range(s2.Range("$A$1"), s2.Cells(1, mCol)).Interior.Color = mColor(k)
s1.Activate
'------ここまでを挿入

Set s2 = Nothing
Set sP = Nothing
If k = 9 Then

お礼

お願い致しました要望に対応して下さり、私が気づけなかったタイトル行の固定と色塗りつぶしについても、ご教示を頂きまして有難うございました。ご教示通りにマクロで実行出来ました。
これまでも、タイトル行を固定してデータを確認していますので、手間が省けて大変便利になりました。
これで、今回の質問は完了とさせて頂きます。本当に有難うございました。

回答No.16

kkkkkm

Sub Test3_3()
Dim Wb As Workbook
Dim s1 As Worksheet, s2 As Worksheet, sP As Worksheet
Dim i As Long, j As Long, sCount As Long, k As Long
Dim arr1 As Variant, arr2 As Variant, arrP As Variant
Dim FullPath As Variant, FileName As String
Dim mRow As Long, mCol As Long
Dim mRng As Range
Dim mColor() As Variant

'ここでフォルダを指定しておくとそのフォルダでファイルを開くダイアログがでます。
'ChDir "C:\Ok"

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
'色見本セルを使わずに直接色番号を指定する場合
'mColor = Array(11854022, 15189684, 10086143, 14408667, 11389944, 13285804, 9359529, 14395790, 6740479, 13224393)

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

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

'比較元シートのセルの塗りつぶしをクリアします
s1.Range(s1.Range("$A$2"), s1.Cells.SpecialCells(xlCellTypeLastCell)).Interior.ColorIndex = xlNone

k = 0

mRow = s1.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s1.Cells.SpecialCells(xlCellTypeLastCell).Column

For sCount = 2 To Wb.Sheets.Count

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

'過去最大となる行番号と列番号を変数に設定
If mRow < s2.Cells.SpecialCells(xlCellTypeLastCell).Row Then
mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
End If
If mCol < s2.Cells.SpecialCells(xlCellTypeLastCell).Column Then
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
End If

arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).Value
arr2 = s2.Range(s2.Range("$A$2"), s2.Cells(mRow, mCol)).Value

If sCount > 2 Then
Set sP = Wb.Worksheets(sCount - 1) '比較先のひとつ前のシート
arrP = sP.Range(sP.Range("$A$2"), sP.Cells(mRow, mCol)).Value
End If

For i = 1 To UBound(arr1, 1)
For j = 1 To UBound(arr1, 2)
If arr1(i, j) <> arr2(i, j) Then
'塗りつぶし処理
If sCount > 2 Then
If s1.Cells(i + 1, j).Interior.ColorIndex <> xlNone And arr2(i, j) = arrP(i, j) Then
'修正前データが塗りつぶされていて前回と値が同じなら前回の色で
s2.Cells(i + 1, j).Interior.Color = sP.Cells(i + 1, j).Interior.Color
Else
s1.Cells(i + 1, j).Interior.Color = mColor(k)
s2.Cells(i + 1, j).Interior.Color = mColor(k)
'タブの色を塗りつぶしと同じ色に変更
s2.Tab.Color = mColor(k)
End If
Else
s1.Cells(i + 1, j).Interior.Color = mColor(k)
s2.Cells(i + 1, j).Interior.Color = mColor(k)
'タブの色を塗りつぶしと同じ色に変更
s2.Tab.Color = mColor(k)
End If
'--------------------
ElseIf sCount > 2 Then
'前回までの変更が修正前データに戻されていた場合それ以降変更されるまでのシートの同一セル
'及び最大に達していないシートの過去最大の行までの塗りつぶし
If s1.Cells(i + 1, j).Interior.ColorIndex <> xlNone Then
s2.Cells(i + 1, j).Interior.Color = vbYellow
End If
'--------------------
End If
Next
Next
'色見本のセルにシート名を記述
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = s2.Name

Set s2 = Nothing
Set sP = Nothing
If k = 9 Then
k = 0
Else
k = k + 1
End If
Next
On Error Resume Next
Wb.SaveAs Left(FullPath, InStrRev(FullPath, "\")) & "【チェック済】" & FileName
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "保存時にエラーが発生したかキャンセルされました。", vbInformation
Err.Clear
End If
On Error GoTo 0

Set s1 = Nothing
Set Wb = Nothing

End Sub

お礼

早速のマクロの修正、誠にありがとうございました。
本日、マクロをテストしまして、ご報告通りに差分比較塗りつぶしが
ご報告の通りになった事を確認致しました。
更に、私以外でも使えるように、シート2にマクロ実行ボタンを作り、ボタンを押す事でマクロを実行出来るようにしました。

条件を事細かに考えて下さり、説明も分かり易く大変感謝致します。
マクロは、今の所、このままで使用させて頂きます。
今回のマクロも末永く使わせて頂きます。
これまでにご教示頂いたマクロも、今でも大変重宝して使わせて頂いております。

補足

ご教示頂いたマクロはそのまま使わせて頂くとご報告したのに大変恐縮ですが、もう1点のみ、ご教示頂きたい事がございます。

例えば、出力ファイルに結果を出力する時、
出力ファイルのシート1(修正前データ)で塗りつぶしセル(修正後の差分部分)のフォントの色を黒字から白色の文字へ変更するコードを知りたいのですが、ご参考までにご教示頂く事は可能でしょうか？

回答No.15

kkkkkm

結果報告ありがとうございます。

削除した時は修正範囲からなくなるので範囲としていらないと思ったのですがそうでもなかったですね。

修正前データ(シート1)の行数と修正各シートの行数と比較して大きい方を比較範囲とすることも考えたのですが、実行後最大の行数を範囲とした方が安全そうなのでそちらにしました。

以下のような感じになります。

修正前データ(シート1)データ総行数は548行。

修正1回目データ(シート2)のデータ総行数は545行(最終行から3行削除)
比較範囲を548行までにします。削除された部分も範囲になりますので条件一致したセルは塗りつぶされます。

修正2回目データ(シート3)のデータ総行数は551行。(最終行から3行データ追加)
比較範囲を551行までにします

修正3回目データ(シート4)のデータ総行数は539行。(最終行から9行削除)
比較範囲を551行のままにします。削除された部分も範囲になりますので条件一致したセルは塗りつぶされます。

修正4回目データ(シート5)のデータ総行数は560行。(最終行から12行追加)
比較範囲を560行までにします

また、最後のファイルの保存時に上書きするかどうかの問い合わせが出た場合キャンセルするとエラーで止まってましたので、メッセージを出してエラーにならないようにしました。

あと、これもふと思ったのですが、たとえば1回目で修正して2回目で意図してか偶然かによらず修正前のデータに戻した(戻ってしまった)セルは2回目では色なしになります。
この場合、元に戻ったシート以降のシートのセルを黄色にして(次に変更されるまで)一度は変更された事を知らせるという方法もありかなと思いましたので追加してみました。修正前データより実行後最大の行までの部分も黄色になります。
いらない場合は

'--------------------
ElseIf sCount > 2 Then
'前回までの変更が修正前データに戻されていた場合それ以降変更されるまでのシートの同一セル
'及び最大に達していないシートの過去最大の行までの塗りつぶし
If s1.Cells(i + 1, j).Interior.ColorIndex <> xlNone Then
s2.Cells(i + 1, j).Interior.Color = vbYellow
End If
'--------------------

の部分を削除してください。

それと

'ここでフォルダを指定しておくとそのフォルダでファイルを開くダイアログがでます。
'ChDir "C:\Ok"

この部分で一覧として最初に開きたいフォルダを指定しておくと便利です。
とりあえずコメントにしています。

行数制限があるみたいなのでコードは次の回答で

回答No.14

kkkkkm

> 元のシートのセルに色が付いていたら色を新たに付けないという方法が良いような気がします。

と回答しましたが、再度質問を読むと
> 3つ目のシート内のデータも、1つ目のデータの値を更に再修正したものです。

という事は、どの修正も1つ目のシートが対象になるのかなと思ったりしましたが

もし上記の状態ではなく

1つ目のシートを修正して2つ目のシート
2つ目のシートを修正して3つ目のシート

という流れでしたら

新たに色を付けないだけだと次の修正でも修正した場合色がつかないので

3つ目のシートで比較している場合
1つ目のシートの該当セルに色がついていたら

3つ目のシートと2つ目のシートの該当セルのデータが同じ場合
3つ目のシートのセルの色を2つ目のシートのセルの色にする

3つ目のシートと2つ目のシートの該当セルのデータが違う場合
3つ目のシートのセルの色と1つ目のシートのセルの色を3つ目のシート用セルの色にする

これでそのシートで修正したもの以外で修正されていたものは過去に修正したセルの色が付くようになると思います。

上記のコードをとりあえず記載しておきますので、状況が上記の場合こちらを利用してみてください。

コードは色見本を使う状態にしていますので適宜変更してください。
変更前の部分をコメントにしていたのを削除しました。
冗長なところがあるかもしれません。

Sub Test3_2()
Dim Wb As Workbook
Dim s1 As Worksheet, s2 As Worksheet, sP As Worksheet
Dim i As Long, j As Long, sCount As Long, k As Long
Dim arr1 As Variant, arr2 As Variant, arrP 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
'色見本セルを使わずに直接色番号を指定する場合
'mColor = Array(11854022, 15189684, 10086143, 14408667, 11389944, 13285804, 9359529, 14395790, 6740479, 13224393)

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

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

'比較元シートのセルの塗りつぶしをクリアします
s1.Range(s1.Range("$A$2"), s1.Cells.SpecialCells(xlCellTypeLastCell)).Interior.ColorIndex = xlNone

k = 0

For sCount = 2 To Wb.Sheets.Count

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

mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).Value
arr2 = s2.Range(s2.Range("$A$2"), s2.Cells(mRow, mCol)).Value
If sCount > 2 Then
Set sP = Wb.Worksheets(sCount - 1) '比較先のひとつ前のシート
arrP = sP.Range(sP.Range("$A$2"), sP.Cells(mRow, mCol)).Value
End If

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

Set s2 = Nothing
Set sP = Nothing
If k = 9 Then
k = 0
Else
k = k + 1
End If
Next

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

Set s1 = Nothing
Set Wb = Nothing

End Sub

お礼

1例ですが、マクロを実施した結果を下記のようにご報告させて頂きました。
修正で最終行にデータを追加した場合、追加した行は修正前データには反映されますが、
修正で最終行から数行削除をした場合、削除した行は修正前データには反映されないようです。

修正前データ(シート1)データ総行数は548行。
マクロ実行結果＝2回目修正でデータ追加した行が2回目修正の色でぬりつぶされた。

修正1回目データ(シート2)のデータ総行数は545行(最終行から3行削除)
マクロ実行結果＝削除したデータのセルは塗り潰し無し。

修正2回目データ(シート3)のデータ総行数は551行。(最終行から3行データ追加)
マクロ実行結果＝追加データのセルが塗りつぶされる。

修正4回目データ(シート4)のデータ総行数は539行。(最終行から9行削除)
マクロ実行結果＝削除したデータのセルは塗り潰し無し。

可能であれば、ご紹介頂いたマクロで修正で削除したデータも、
修正前に反映されるようになると大変助かります。
難しさも分からずお願いしているかもしれません、その時は申し訳ありません。

補足

よく分かってないものですから、こんなものかなと感じておりましたが、更に分かり易いマクロをご紹介頂き、本当に感謝致します。

test3のマクロでは、以下になっている事を確認しました。
『A2を最初に修正して次はA2に手を加えずに修正されたままだった場合
　元のシートのセルの色は次に修正したシートの色になる。』

test3-2のマクロでは、以下になっている事を確認しました。
『元のシートのセルに色が付いていたら色を新たに付けないという方法
　3つ目のシートと2つ目のシートの該当セルのデータが同じ場合
　3つ目のシートのセルの色を2つ目のシートのセルの色にする』
『3つ目のシートと2つ目のシートの該当セルのデータが違う場合
　3つ目のシートのセルの色と1つ目のシートのセルの色を3つ目のシート用セルの色にする』

kkkkkmさんのご指摘の通り、元データをベースにした修正箇所チェックは、
『そのシートで修正したもの以外で修正されていたものは過去に修正したセルの色が付く』のやり方にした方が分かり易かったです。
更に、フォマットの違うデータでtest3-2マクロを試させて頂き、差分比較チェックをしてみます。
今の所、マクロファイルのシートへ好みの色を設定出来るこのマクロが、操作し易く良いかなと感じています。
後程、結果をご報告させて頂きます。

回答No.13

kkkkkm

> マクロはもう少しテストさせて頂きます

おかしいところがあったら修正しますので実行しているコード(色々変更したのでどれを採用したのか分からないので)を記載してお知らせください。

あと、ふと思ったのですが、最初に修正して次に修正する時は修正されたものを元にして修正を加えるとしたら
たとえばA2を最初に修正して次はA2に手を加えずに修正されたままだった場合
元のシートのセルの色は次に修正したシートの色になると思います。修正していないシートのセルにも色が付くので都合が悪いのではないでしょうか。
もし上記の状態でしたら元のシートのセルに色が付いていたら色を新たに付けないという方法が良いような気がします。

回答No.12

SI299792

前プログラムに、フォント色変更機能を付けました。
赤、青等、黒だと醜い色の時、フォントを白にします。
最も、シートによって色を変えるのて必要になった機能で、色が１色だけなら不要ですが。
Option Explicit
'
Sub Macro1()
　　Dim File As Variant
　　Dim SheetNo As Integer
　　Dim Cell1 As Range
　　Dim Cell2 As Range
'
　　File = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")
'
　　If File = False Then
　　　　End
　　End If
　　Application.ScreenUpdating = False
　　Set File = Workbooks.Open(File, False)
'
　　For SheetNo = 2 To Sheets.Count
'
　　　　For Each Cell1 In Sheets(1).UsedRange
　　　　　　Set Cell2 = Sheets(SheetNo).Range(Cell1.Address)
'
　　　　　　If Cell1 <> Cell2 Then
　　　　　　　　Cell1.Interior.ColorIndex = SheetNo + 1
　　　　　　　　Cell1.Font.Color = FontColor(Cell1.Interior.Color)
　　　　　　　　Cell2.Interior.Color = RGB(102, 255, 51)
　　　　　　End If
　　　　Next Cell1
　　Next SheetNo
　　SheetNo = InStrRev(File.FullName, ".") - 1
　　File.SaveAs Left(File.FullName, SheetNo) & "色付"
　　File.Close
　　MsgBox "処理終了"
End Sub
'
Function FontColor(ByVal IColor As Long) As Long
　　Dim SColor As Integer
　　Dim Mul As Integer
'
　　Mul = 1
'
　　Do While IColor > 0
　　　　Mul = Mul Mod 3 + 1
　　　　SColor = SColor + (IColor Mod 256) * Mul
　　　　IColor = IColor \ 256
　　Loop
　　FontColor = vbWhite * -(SColor < 764)
End Function

\ は半角￥にして下さい。（コピペすれば半角￥になります）
ファイル名の指定・出力ファイル名はこれでいいですか❓

お礼

マクロのご教示を頂きまして、誠にありがとうございました。大変勉強になりました。又、私が気づけなかった、塗りつぶしセルのフォントの色を変更して見易くする方法も紹介して下さり感謝しております。

Powered by GRATICA

回答No.11

kkkkkm

またまた余計なお世話ですが

回答No.9で添付画像の色でよろしければ

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

の部分を

mColor = Array(11854022, 15189684, 10086143, 14408667, 11389944, 13285804, 9359529, 14395790, 6740479, 13224393)

とすれば色見本のセルはいらなくなります。

最後の方の
ThisWorkbook.Sheets("Sheet1").Cells(k + 1, "A").Value = s2.Name
も色見本が無いのでいりませんね。

上記の方法でご自身の好みの色でやりたいとかありましたら

関係の無い別のブックでもOKですので

Sheet1のA1からA10まで色を付けたとして

Sub t()
Dim mRng As Range
Cells(1, "C").Value = ""
For Each mRng In Sheets("Sheet1").Range("A1:A10")
Cells(1, "C").Value = Cells(1, "C").Value & "," & mRng.Interior.Color
Next
Cells(1, "C").Value = "mColor = Array(" & Mid(Cells(1, "C").Value, 2) & ")"
End Sub

を実行すればC1にデータができますのでコピペしてください。

10回以上修正がある場合は、10色以上セット(もしくは色見本のセル)すればいいですが、10色を繰り返してもいいのじゃないかとも思えます。

その場合最後の方にある

k = k + 1

のところを

If k = 9 Then
k = 0
Else
k = k + 1
End If

としておくと10色繰り返しになります。

補足

データチェック後の塗りつぶし色の下記の設定方法を、
大変分かり易く説明して頂き、誠に有難うございました。
①マクロによる色番号の作り方
②入力データの各シートタブの色塗りつぶしの色にする。
③マクロ内のシート1：A1～A10のセルの塗りつぶし通りの色にする。
④データ修正が10回以上の時の塗りつぶしは繰り返しにする。
未熟物の自分には、このようなマクロを作成する事は出来ず、マジックでも見ているようで、わくわくドキドキしながら、ご紹介頂いた項目を実行して見ました。
データ修正10回以上はまだ未実施ですが、その他の項目は、全て問題なく塗りつぶし色を設定する事が出来ました。
マクロはもう少しテストさせて頂きます。
取り急ぎ御礼まで。

回答No.10

kkkkkm

何度もすみません

回答No.7で

2つ目のシート以降では修正によって範囲が増えるという事でしたら以下になります。

と回答しましたが、上記の場合だけではなく

修正前のデータ範囲と修正後のデータ範囲が違う場合は増減に関わらず
回答No.7のコードにしてください。

質問のコードを基にしてますので、回答No.7より前のコードは修正前のデータ範囲と修正後のデータ範囲は同じという前提でのコードになっています。

範囲が同じでも回答No.7のコードで問題はありませんから回答No.7のコードでテストしてみてください。

回答No.7のコードで修正後のデータ範囲でチェックするというのを分かりやすくするために

arr2 = s2.Range(s2.Range("$A$2"), s2.Cells.SpecialCells(xlCellTypeLastCell)).Value
mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).Value

の部分を

' arr2 = s2.Range(s2.Range("$A$2"), s2.Cells.SpecialCells(xlCellTypeLastCell)).Value
mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).Value
arr2 = s2.Range(s2.Range("$A$2"), s2.Cells(mRow, mCol)).Value

としてもいいかもしれません。

回答No.9

kkkkkm

回答No.6の余計なお世話をしてみたコードを実行した時の画像をつけ忘れてました

タブに色を付ければ修正前のシート(Sheet1)を見れば、どの時点で修正が行われたのかはセルと同じ色のシートを開けば分かるようになりますので、あれこれシートを探す手間が省けます。また、タブに色が付けられない場合、色見本のセルにその色を使ったシート名が記載されますので、それを見て該当シートを開くことができます。

マクロ実行のブックの色見本のシートのセルに記載されているシート名はマクロ実行で自動で記載されます。
セルの色だけ先に好みの色で塗りつぶしておいてください。

回答No.8

kkkkkm

回答No.7の追加です。

比較するシートのタブにもともと色を付けているのでしたら

'塗りつぶし処理
s1.Cells(i + 1, j).Interior.Color = s2.Tab.Color
s2.Cells(i + 1, j).Interior.Color = s2.Tab.Color

としておけばタブと同じ色でセルが塗りつぶされます。

回答No.7

kkkkkm

> 2つ目のシート内は1つ目のシートの値を部分的に修正したものです。

との事でしたので、修正前のデータ範囲と修正後のデータ範囲は同じだと思っていたのですが

> 修正で行が増える事があります。

これが
1つ目のシート修正前のデータ範囲
は増えないけど
2つ目のシート以降では修正によって範囲が増えるという事でしたら以下になります。

前回と同じように必要のない部分はコメントにしています。色変化付きのコードです。

Sub Test3()
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
mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).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

色は元のままでいいよという場合はこちら

Sub Test4()
Dim Wb As Workbook
Dim s1, s2 As Worksheet 'Worksheetsオブジェクト用
Dim i As Long, j As Long, sCount 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

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

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

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
mRow = s2.Cells.SpecialCells(xlCellTypeLastCell).Row
mCol = s2.Cells.SpecialCells(xlCellTypeLastCell).Column
arr1 = s1.Range(s1.Range("$A$2"), s1.Cells(mRow, mCol)).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

Set s2 = Nothing
Next

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

Set s1 = Nothing
Set Wb = Nothing

End Sub