異なるブックの２つシートを比較して差異のある部分を抽出する。
２つのシートの内容を比較して差異がある部分を抽出する機能をVBAで作成しています。
比較できる内容はセルに入力された 値、数式、文字色と背景色、フォントに差異があればそのセルの情報が出力されるようになっています。
サンプルコードでは下記のような「設定シート」に比較したいシートなどの情報を指定し、その情報を元に比較を行います。
※設定シートを自動で作成するコードをページ下部（リンクからその箇所に移動します）に記載しています。
差異の比較ができる内容は設定フラグ（C8～C11セル）を用いることで比較させたい内容の選択ができます。
動作確認
Windows10/Excel2016:○
Windows11/Excel2024:○
●シートの比較
Const SHT_PARM = "設定シート"
Const SHT_RESULT = "比較結果"
'******************************************************************
' シート比較
'******************************************************************
Sub Main_Compare()
'初期化
ThisWorkbook.Activate
'比較結果のシートが無ければ作成
If Not ChkExistSheet(ThisWorkbook, SHT_RESULT) Then
Sheets.Add After:=Sheets(SHT_PARM)
ActiveSheet.Name = SHT_RESULT
Else
Sheets(SHT_RESULT).Cells.Clear
End If
'入力値チェック
Dim sBookName(1) As String
sBookName(0) = Sheets(SHT_PARM).Range("D4")
sBookName(1) = Sheets(SHT_PARM).Range("D5")
Dim sBaseSheet(1) As String
sBaseSheet(0) = Sheets(SHT_PARM).Range("E4")
sBaseSheet(1) = Sheets(SHT_PARM).Range("E5")
If sBookName(0) = "" Or sBookName(1) = "" Or _
sBaseSheet(0) = "" Or sBaseSheet(1) = "" Then
MsgBox "比較対象のブック、またはシート名が入力されていません。"
Exit Sub
End If
'設定パラメータ作成
Dim i As Long
Dim sChkPram(3) As String
For i = 0 To 3
sChkPram(i) = CStr(Sheets(SHT_PARM).Cells(i + 8, 3))
Next
'ブックを開く
Dim oBook(1) As Object
Set oBook(0) = Workbooks.Open(sBookName(0))
Set oBook(1) = Workbooks.Open(sBookName(1))
'比較対象シートの存在チェック
For i = 0 To 1
If Not (ChkExistSheet(oBook(i), sBaseSheet(i))) Then
MsgBox oBook(i).Name & "に" & vbCrLf & sBaseSheet(i) & "シートがありません。"
oBook(0).Close
oBook(1).Close
Exit Sub
End If
Next
'シートオブジェクト取得
Dim oSheet(1) As Object
Set oSheet(0) = oBook(0).Worksheets(sBaseSheet(0))
Set oSheet(1) = oBook(1).Worksheets(sBaseSheet(1))
'シート比較
Call CompareSheet(oSheet, sChkPram)
'結果シートの整形
Call formatResultSht
oBook(0).Close False
oBook(1).Close False
End Sub
'******************************************************************
' シート存在チェック
'------------------------------------------------------------------
' 第１引数：ブックオブジェクト
' 第２引数：テキストファイルのパス
'------------------------------------------------------------------
' 戻り値 ：確認結果（True:シートあり、False:シートなし）
'******************************************************************
Function ChkExistSheet(getBk As Object, getShtNm As String)
ChkExistSheet = False
Dim oChkObj As Object
For Each oChkObj In getBk.Sheets
If getShtNm = oChkObj.Name Then
ChkExistSheet = True
Exit For
End If
Next
End Function
'******************************************************************
' シート比較
'------------------------------------------------------------------
' 第１引数：シートオブジェクト
' 第２引数：比較対象の設定
'******************************************************************
Sub CompareSheet(getSht() As Object, getPram() As String)
'シートの比較範囲を取得
Dim lRow As Long
Dim lCol As Long
Call getCompareRange(getSht(), lRow, lCol)
'出力用のブックをアクティブにする
ThisWorkbook.Activate: Sheets(SHT_RESULT).Select
'比較範囲を結果に出力
Sheets(SHT_RESULT).Range("F2") = "A1～" & Cells(lRow, lCol).Address(0, 0)
'比較実行
Dim i As Long 'Roｗ
Dim j As Long 'Column
Dim k As Long '記載行
k = 4
With Sheets(SHT_RESULT)
For i = 1 To lRow: For j = 1 To lCol
'値
If (getPram(0) = "1") And _
(getSht(0).Cells(i, j).Text <> getSht(1).Cells(i, j).Text) Then
.Cells(k, 2) = getSht(0).Cells(i, j).Address(0, 0)
.Cells(k, 3) = "値"
.Cells(k, 4) = getSht(0).Cells(i, j).Text
.Cells(k, 5) = getSht(1).Cells(i, j).Text
.Cells(k, 6) = ""
k = k + 1
End If
'数式(Formulaの先頭文字が"="であれば数式と判断)
If (getPram(1) = "1") And _
(Left(getSht(0).Cells(i, j).Formula, 1) = "=" And _
Left(getSht(1).Cells(i, j).Formula, 1) = "=") Then
If getSht(0).Cells(i, j).Formula <> getSht(1).Cells(i, j).Formula Then
.Cells(k, 2) = getSht(0).Cells(i, j).Address(0, 0)
.Cells(k, 3) = "数式"
.Cells(k, 4) = "'" & getSht(0).Cells(i, j).Formula
.Cells(k, 5) = "'" & getSht(1).Cells(i, j).Formula
.Cells(k, 6) = "※数式表示の為、文字の先頭にシングルクォーテーション(')を付与。"
k = k + 1
End If
End If
'文字色・背景色
If (getPram(2) = "1") Then
If (getSht(0).Cells(i, j).Font.Color <> getSht(1).Cells(i, j).Font.Color) Or _
(getSht(0).Cells(i, j).Interior.Color <> getSht(1).Cells(i, j).Interior.Color) Then
.Cells(k, 2) = getSht(0).Cells(i, j).Address(0, 0)
.Cells(k, 3) = "文字色・背景色"
.Cells(k, 4) = getSht(0).Cells(i, j).Text
.Cells(k, 5) = getSht(1).Cells(i, j).Text
.Cells(k, 4).Font.Color = getSht(0).Cells(i, j).Font.Color
.Cells(k, 5).Font.Color = getSht(1).Cells(i, j).Font.Color
.Cells(k, 4).Interior.Color = getSht(0).Cells(i, j).Interior.Color
.Cells(k, 5).Interior.Color = getSht(1).Cells(i, j).Interior.Color
.Cells(k, 6) = ""
k = k + 1
End If
End If
'フォント
If (getPram(3) = "1") And _
(getSht(0).Cells(i, j).Font.Name <> getSht(1).Cells(i, j).Font.Name) Then
.Cells(k, 2) = getSht(0).Cells(i, j).Address(0, 0)
.Cells(k, 3) = "フォント"
.Cells(k, 4) = getSht(0).Cells(i, j)
.Cells(k, 5) = getSht(1).Cells(i, j)
.Cells(k, 4).Font.Name = getSht(0).Cells(i, j).Font.Name
.Cells(k, 5).Font.Name = getSht(1).Cells(i, j).Font.Name
.Cells(k, 6) = getSht(0).Cells(i, j).Font.Name & " / " & getSht(1).Cells(i, j).Font.Name
k = k + 1
End If
Next: Next
End With
End Sub
'******************************************************************
' シートの比較範囲を取得
'------------------------------------------------------------------
' 第１引数：シートオブジェクト
' 第２引数：行番号（戻り値）
' 第３引数：列番号（戻り値）
'******************************************************************
Sub getCompareRange(getSht() As Object, ByRef rtnRow As Long, ByRef rtnCol As Long)
'比較範囲の取得
Dim lMaxRow(1) As Long
Dim lMaxCol(1) As Long
'１つ目のシートの使用範囲を取得
With getSht(0)
lMaxRow(0) = .UsedRange.Item(.UsedRange.Count).Row
lMaxCol(0) = .UsedRange.Item(.UsedRange.Count).Column
End With
'２つ目のシートの使用範囲を取得
With getSht(1)
lMaxRow(1) = .UsedRange.Item(.UsedRange.Count).Row
lMaxCol(1) = .UsedRange.Item(.UsedRange.Count).Column
End With
'行列の最大値を取得し比較範囲を設定
Dim lRow As Long
If lMaxRow(0) >= lMaxRow(1) Then
rtnRow = lMaxRow(0)
Else
rtnRow = lMaxRow(1)
End If
Dim lCol As Long
If lMaxCol(0) >= lMaxCol(1) Then
rtnCol = lMaxCol(0)
Else
rtnCol = lMaxCol(1)
End If
End Sub
'******************************************************************
' 比較結果シートの整形
'******************************************************************
Sub formatResultSht()
ThisWorkbook.Activate
With Sheets(SHT_RESULT)
'ヘッダの設定
.Range("B1") = "比較結果"
.Range("B3") = "差異セル"
.Range("C3") = "比較対象"
.Range("D2") = Sheets(SHT_PARM).Range("D4")
.Range("E2") = Sheets(SHT_PARM).Range("D5")
.Range("D3") = Sheets(SHT_PARM).Range("E4")
.Range("E3") = Sheets(SHT_PARM).Range("E5")
.Range("F2") = "比較のセル範囲 : " + .Range("F2")
.Range("B2:F3").Interior.Color = 14348257
'列幅の設定
.Columns("B").ColumnWidth = 8.5
.Columns("C").ColumnWidth = 14.5
.Columns("D:E").ColumnWidth = 32
.Columns("F").ColumnWidth = 60
'罫線を引く範囲を取得
Dim sResultRange As String
sResultRange = "B2:" & Cells( _
.UsedRange.Item(.UsedRange.Count).Row, _
.UsedRange.Item(.UsedRange.Count).Column) _
.Address(0, 0)
'罫線
.Range(sResultRange).Borders(xlEdgeTop).LineStyle = xlContinuous
.Range(sResultRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Range(sResultRange).Borders(xlEdgeLeft).LineStyle = xlContinuous
.Range(sResultRange).Borders(xlEdgeRight).LineStyle = xlContinuous
.Range(sResultRange).Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Range(sResultRange).Borders(xlInsideVertical).LineStyle = xlContinuous
'文字の表示位置
.Range(sResultRange).HorizontalAlignment = xlLeft
End With
End Sub
■実行
下記の２つのシートを比較します。
※値、数式、文字色と背景色、フォントのすべてのチェックをしています。
■実行結果
B列：差異のあったセル
C列：差異内容
D、E列：両シートのセル情報
F列：補足欄（フォントを選択している場合は、両セルに設定されているフォント名を表示）
●設定シートの作成
入力用の設定シートを自動で作成してくれるコードです。
使う場合は、定数や共通で利用している関数があるため、上記で紹介しているコードと同じモジュール内にこのコードをコピーして使ってください。
'******************************************************************
' 設定シートの作成
'******************************************************************
Sub MakeSettingSheet()
Dim sSetSht As String: sSetSht = "設定シート"
If Not ChkExistSheet(ThisWorkbook, sSetSht) Then
Sheets.Add After:=Sheets(1)
ActiveSheet.Name = sSetSht
Else
Sheets(sSetSht).Cells.Clear
End If
ThisWorkbook.Activate
With Sheets(sSetSht)
.Range("B3:E3").Interior.Color = 13431550
.Range("B4:C5").Interior.Color = 13431550
.Range("B7:D7").Interior.Color = 13431550
.Range("B8:B11").Interior.Color = 13431550
.Range("A1") = "シート比較"
.Range("B2") = "設定"
.Range("B4") = "対象"
.Range("C4") = "１"
.Range("C5") = "２"
.Range("D3") = "ブックのパス（フルパス）"
.Range("E3") = "シート名"
.Range("B7") = "比較内容"
.Range("C7") = "設定"
.Range("D7") = "備考"
.Range("B8") = "値"
.Range("B9") = "数式"
.Range("E9") = "数式の比較は数式同士の比較"
.Range("B10") = "文字色・背景色"
.Range("B11") = "フォント"
.Range("D8") = "1：比較する" & vbCrLf & "1以外: 比較しない"
'罫線
.Range("B3:E5").Borders(xlEdgeTop).LineStyle = xlContinuous
.Range("B3:E5").Borders(xlEdgeBottom).LineStyle = xlContinuous
.Range("B3:E5").Borders(xlEdgeLeft).LineStyle = xlContinuous
.Range("B3:E5").Borders(xlEdgeRight).LineStyle = xlContinuous
.Range("B3:E5").Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Range("B3:E5").Borders(xlInsideVertical).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlEdgeTop).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlEdgeBottom).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlEdgeLeft).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlEdgeRight).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Range("B7:D11").Borders(xlInsideVertical).LineStyle = xlContinuous
.Columns("B").ColumnWidth = 14.5
.Columns("C").ColumnWidth = 5.25
.Columns("D").ColumnWidth = 33.5
.Columns("E").ColumnWidth = 14.75
.Range("B3:C3").Merge
.Range("B4:B5").Merge
.Range("B4:B5").VerticalAlignment = xlTop
.Range("D8:D11").Merge
.Range("D8:D11").VerticalAlignment = xlTop
.Rows.AutoFit
.Cells.Font.Name = "BIZ UDゴシック"
'初期値
.Range("C8") = "1"
.Range("C9") = "1"
.Range("C10") = "0"
.Range("C11") = "0"
End With
End Sub
