仕様
EXCELブック同士を比較するツールを作成しました。
下準備としてはこのツールが乗るEXCELブックのC2に比較Aファイル、C3に比較Bファイル、C4に比較結果ファイルを指定してください。
フルパスです。
シチュエーションとしては変更を掛けたブックの差分をみたり、環境違いのファイルを比較するのにお使いください。
ブックAをコピーしCとします。AとBのセルを1つずつ比較し、違った場合はCブックの該当セルを黄色くし、コメントに差分内容(B側)を残します。
実ファイルをそのまま参照せず、コピーを取って使用してください。
仕様としては下記になります。
・Aのワークシートの印刷範囲を使い、対象範囲を決定します。この時空白ワークシートの場合はスキップをします。
・結合セルがあっても対応しています。
苦労した点
対象範囲がシートごとに違うのでどうしようかと思いましたが、印刷範囲を利用すれば漏れが減るかと思い、「.PageSetup.PrintArea」を採用しました。
結合セルがあると左上には値が格納されいますが、それ以外は空白扱いなのでエラーを出してしまいます。なのでマージセルであった場合は「CellA.MergeArea(1)」で値を格納しそれを比較してエラーを回避させています。
Sub ComoareAndOutput()
Dim wbA As Workbook
Dim wbB As Workbook
Dim wbC As Workbook
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim wsC As Worksheet
Dim CellA As Range
Dim CellB As Range
Dim CellC As Range
Dim wbApath As Variant
Dim wbBpath As Variant
Dim wbCpath As Variant
Dim i As Long
Dim j As Long
Dim lastRowA As Long
Dim lastColumnA As Long
Dim Count_WS As Long
Dim PrintArea_wsA As Variant
Application.ScreenUpdating = False
MsgBox "比較処理を開始します。しばらくお待ちください。"
' ブックを開く
Set wbApath = Range("C2")
Set wbBpath = Range("C3")
Set wbCpath = Range("C4")
'ファイルをコピーします。
Dim objFSO As Object, txtSource As String, txtDestination
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile wbApath, wbCpath
Set wbA = Workbooks.Open(wbApath)
Set wbB = Workbooks.Open(wbBpath)
Set wbC = Workbooks.Open(wbCpath)
For Count_WS = 1 To wbA.Worksheets.Count
Set wsA = wbA.Worksheets(Count_WS)
Set wsB = wbB.Worksheets(Count_WS)
Set wsC = wbC.Worksheets(Count_WS)
With wsA
'使用しているセル範囲を印刷範囲に設定する。
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(4, 4)).Address
If WorksheetFunction.CountA(.UsedRange) = 0 And Worksheets.Count > 1 Then
Else
.PageSetup.PrintArea = .UsedRange.Address
End If
'印刷範囲を引数に格納する。
PrintArea_wsA = .PageSetup.PrintArea
End With
Cell_tmp_A = Split(PrintArea_wsA, "$")
Cell_tmp_A_ROW = Cell_tmp_A(3)
Cell_tmp_A_Column = Cell_tmp_A(4)
'アルファベットを数字に変換
ColNo = Range(Cell_tmp_A_ROW & "1").Column
lastRowA = ColNo
lastColumnA = Cell_tmp_A_Column
' AをベースにBを比較しCに出力する。
For i = 1 To lastRowA
For j = 1 To lastColumnA
Set CellA = wsA.Cells(i, j)
Set CellB = wsB.Cells(i, j)
Set CellC = wsC.Cells(i, j)
' 結合セルかどうか確認する。
If CellA.MergeCells Then
'空白かどうか確認する。
If Not IsNull(wsA.Cells(i, j).Value) And Len(Trim(wsA.Cells(i, j).Value)) > 0 Then
'AブックとBブックを比較し、差分がある場合は黄色セルにし、コメントで差分を残す。
If CellA.MergeArea(1) <> CellB.MergeArea(1).Value Then
CellC.MergeArea(1).Interior.Color = 65535
CellC.MergeArea(1).AddCommentThreaded (CellB.MergeArea(1).Value)
Else
End If
End If
Else
'空白かどうか確認する
If Not IsNull(wsA.Cells(i, j).Value) And Len(Trim(wsA.Cells(i, j).Value)) > 0 Then
'AブックとBブックを比較し、差分がある場合は黄色セルにし、コメントで差分を残す。
If wsA.Cells(i, j).Value <> wsB.Cells(i, j).Value Then
wsA.Cells(i, j).Copy
wsC.Cells(i, j).PasteSpecial
wsC.Cells(i, j).Interior.Color = 65535
wsC.Cells(i, j).AddCommentThreaded (wsB.Cells(i, j).Value)
Else
End If
End If
End If
Next j
Next i
Next Count_WS
' 結果を保存する。比較元は保存しない。
wbC.Save
wbC.Close
wbB.Close SaveChanges:=False
wbA.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox "処理が終了しました。" & wbCpath & "を確認してください"
End Sub
以上です。