Excelファイルを比較し、差分箇所に色をつけるには？

質問

VBA初心者です。
突如作成を依頼されてしまいました。
どなたかお手すきでしたら、よろしくお願いします。

まず２つのフォルダＡ（新しいデータのExcelファイル）、
フォルダＢ（古いデータのExcelファイル）があります。

それぞれには同じ名前のExcelファイルが200個近く入っているのですが、
新旧同じ名前同士のファイルを比較し、差分箇所に色をつけるという
作業をしたいのです。（新旧のファイルどちらにも色を付ける）

できればフォルダＡとフォルダＢを選択したら勝手に処理してくれるという
プログラムにしたいのですが、どのようにしたらよろしいでしょうか。

数値の比較ですが、範囲を指定してマッチしてなければ色付け、という
処理でもいいかな・・と思っております。

どうかよろしくお願いします。

回答No.2

fumufumu_2006 · ベストアンサー

こんなのではどうでしょうか？

両フォルダには同じ名前のExcelファイル（各シート数も同じ）があるとして、片方からだけ見てます。
同名のブックを開けないので作業フォルダに別名でコピーして作業をして戻してます。（これが結構長くしてる）
Const workFolder ="???"を適当に設定してください。
シートのチェックはUsedRange内のチェックをしてます。
さすがにこれは片方からだけとはいかないので両方からチェックしてます。
当然ダブってチェックする部分がほとんどですが・・・処理が長くなりそうなのでダブり部分のチェックはしません。
かわりに作業の進行状況をステータスバーに表示しますので、シートにボタンを作って、ボタンのクリックからsampleを呼んでみてください。

Option Explicit
Const workFolder = "c:\temp" '適当な作業フォルダを設定してください。
Sub sample()
Dim srcFolder As String
Dim dstFolder As String
srcFolder = "c:\test\a" 'フォルダＡ
dstFolder = "c:\test\b" 'フォルダＢ

Dim fso As New FileSystemObject
Dim srcFile As String
Dim dstFile As String
Dim srcWorkFile As String
Dim dstWorkFile As String
Dim f As File
Dim n As Integer '進行状況表示用
Dim i As Integer '進行状況表示用
'表示設定
Application.DisplayStatusBar = True 'ステータスバー表示
Application.ScreenUpdating = False '画面更新禁止
'作業ファイル名
srcWorkFile = workFolder & "\src.xls"
dstWorkFile = workFolder & "\dst.xls"
n = fso.GetFolder(srcFolder).Files.Count
For Each f In fso.GetFolder(srcFolder).Files
i = i + 1
If f Like "*.xls" Then
'srcFolderのファイルと同じ名前のファイルがdstFolderにもあるとする
srcFile = srcFolder & "\" & f.Name
dstFile = dstFolder & "\" & f.Name
'ステータスバー表示
Application.StatusBar = srcFile & " と " & dstFile & " を、チェック中 (" & i & "/" & n & ")"
'作業フォルダにファイルをコピー
fso.CopyFile srcFile, srcWorkFile, True
fso.CopyFile dstFile, dstWorkFile, True
'ブックチェック
checkBook srcWorkFile, dstWorkFile
'作業フォルダのファイルを戻す
fso.CopyFile srcWorkFile, srcFile, True
fso.CopyFile dstWorkFile, dstFile, True
End If
Next
'作業ファイルを削除
fso.DeleteFile srcWorkFile
fso.DeleteFile dstWorkFile
'後始末
Set fso = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
'ブック(ファイル)のチェック
Sub checkBook(srcFile As String, dstFile As String)
Dim srcBook As Workbook
Dim dstBook As Workbook
Dim ws As Worksheet
Set srcBook = Workbooks.Open(srcFile)
Set dstBook = Workbooks.Open(dstFile)
'srcBookのシート名と同じシートがdstBookにもあるとしてチェック
For Each ws In srcBook.Worksheets
checkSheet ws, dstBook.Worksheets(ws.Name)
Next
srcBook.Close savechanges:=True
dstBook.Close savechanges:=True
End Sub
'シートのチェック
Sub checkSheet(srcSheet As Worksheet, dstSheet As Worksheet)
'背景色のクリア
srcSheet.Cells.Interior.ColorIndex = xlNone
dstSheet.Cells.Interior.ColorIndex = xlNone
'両方のUsedRange範囲内で変更点をチェック
'ダブってチェックする部分が多いけれど
checkSheetUsedRange srcSheet, dstSheet
checkSheetUsedRange dstSheet, srcSheet
End Sub
'シートのチェック（srcSheetのUsedRange内）
Sub checkSheetUsedRange(srcSheet As Worksheet, dstSheet As Worksheet)
Dim r As Range
For Each r In srcSheet.UsedRange
If r <> dstSheet.Range(r.Address) Then
r.Interior.ColorIndex = 3
dstSheet.Range(r.Address).Interior.ColorIndex = 3
End If
Next
End Sub

お礼

コメントありがとうございます。

お忙しいところココまで考えて頂きありがとうございます。
ほとんど丸投げ的な感じになってしまい申し訳ないという気持ちです・・・。
ほとんどやりたい事は実現されていますので、これを参考に詰めて生きたいと思います。

本当にありがとうございました。