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

質問

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

回答No.5

SI299792

・ファイルをユーザー選択
・範囲の自動指定
ですか。
Sheet1とSheet2の比較、Sheet1とSheet3の比較…（シート名が変わってもいい）
Sheet2とSheet3の比較は行わない。

保存は、上書き保存かファイル名を変更して保存か解りません。安全の為ファイル名を変更して保存にしました。（後ろに「色付」をつける）
Sheet1の色付けは、解りやすいように、シートによって色を変えています。但し、１セルに複数色はつけれないので、複数シートで違う場合は後優先です。
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
　　　　　　　　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

色によってはSheet1のセルは醜いです。補正するプログラムもあります。必要なら変身して下さい。

補足

早速のご教示ありがとうございました。とても便利だと思います。
『Sheet1とSheet2の比較、Sheet1とSheet3の比較、Sheet2とSheet3の比較は行わない。』条件でのチェックも必要になりますので、色々なテストデータのパターンで試させて頂きます。単純にやりたい事をお願いしてしまいましたが、データチェックは奥が深い事がわかりました。
1点ご教示頂きたい事があります。『補正するプログラムもあります。必要なら変身して下さい。』ですが、具体的にはどのようにするのでしょうか？　私のような素人でも出来る事なのでしょうか？

回答No.4

kkkkkm

回答No.1はブックの指定無しでシートの指定をしているので標準モジュールにコードがあればいけてますが、なんか危なっかしいのでブックの指定を入れました。比較元シートとそのセル範囲はループの外に出しました。

Sub Test()
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

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

For sCount = 2 To Wb.Sheets.Count

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

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

Set s2 = Nothing

Next

Workbooks(FileName).Save

Set s1 = Nothing
Set Wb = Nothing

End Sub

補足

早速のご教示有難うございました。
ご指摘の通り、入力ファイルを上書きするより、別名の出力ファイルへ結果を出力した方が良いと気づきました。
【チェック済】の記載を入力ファイル名の前へ追加した出力ファイル名で出す事は可能でしょうか？
また、チェックするセル範囲を"$A$2:$W$548"と指定していますが、範囲はデータが入っているセル領域とする事はかのうでしょうか？修正で行が増える事があります。
大変お手数ですが、そのように修正したマクロを教えて頂けましたら幸いです。

回答No.3

kkkkkm

Set s1 = Worksheets(1) '比較元シート
と
Set s1 = Nothing
はループの外で良かったです

回答No.2

kkkkkm

回答No.1の補足です。

最後に保存するようにしていますが、間違ったファイルを開いても色付けして保存してしまいますので、保存は手動でするとか、比較を実行する前に確認するとか、最後で保存するかどうかを確認するとかなどがあった方がいいのかなと思います。

回答No.1

kkkkkm

一番左のシートが比較元シートで、右に一つずつ比較していきます。

Sub TEST1()

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

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

Workbooks.Open FullPath

For sCount = 2 To Sheets.Count

Set s1 = Worksheets(1) '比較元シート
Set s2 = Worksheets(sCount) '比較先シート

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

Set s1 = Nothing
Set s2 = Nothing

Next

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

End Sub