こんなのではどうでしょうか?
両フォルダには同じ名前の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" 'フォルダA
dstFolder = "c:\test\b" 'フォルダ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
投稿日時 - 2008-04-18 02:07:40