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

お礼

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

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

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

回答No.3

imogasi

これは相当VBAの熟練者で無いと無理だ。
丸投げ的回答期待に見えるが、それも無理だ。
＞Excelファイルが200個近く入っているのですが
これが時間がかかる基になりそう。
ーー
課題要素の分解
（１）＞フォルダＢ（古いデータのExcelファイル）があります
フォルダBのファイルを基にフォルダAを探す、という（存在しなければメッセージを出す）というコードからはじめる（内容コンペアは次の問題としておいておく、省略する）とにしたたら。それが出来ないようでは先に勧めない。
（２）新旧亜フィルを捕まえたら、私ならソート法でやる。
新旧ファイルをキー（たとえば職員に関数ファイルなら、職員番号に
当たるもの）でソートする。
そしてマッチングのロジックで両キーの等しいもの（行）を、内容（列）を比較して、色付けや書き出しをする。
マッチングのロジックが判るかどうか。
ーー
既製ソフトが無いかそういうのを探すことだ。
ーーー
同じというものを比較せねば意味ないのだが、質問に何も書いてなくて、そういうことの意識の弱いうち（レベルで）は、この種のプログラムは無理だ。
ーー
アクセスを使って突合せを考えるほうが、まだ真ともかなと思う。こちらも未経験だと習得に道は遠いが。

お礼

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

複数のヒントを提示していただき、ありがたく思います。
imogasiさんの仰るとおりです。
普段はPHPなどを触っておりほとんどVBAの経験がなく、人員欠如により
急遽作成を依頼されたもので慌てておりました。
丸投げ的文章になってしまった事はお詫びいたします。

回答No.1

kokorone

回答ではありません。
お求めの仕様は、製品版が存在するような、複雑な処理が必要です。
フリーツールでも、制限事項があり、思うように動作しません。

というわけで、お求めの仕様について、丸投げは、禁止事項にもあたるかと思われます。
技術的な（部分的な）助言なら、回答をいただけると思います。

お礼

kokoroneさん

コメントありがとうございます。
同じような処理をするツールをなんとか探して見たいと思います。
ありがとうございました。