2019年1月16日 / 最終更新日時 : 2022年7月22日 officeの杜 msoffice

VBAにて２つのExcelシートの差分を取り出してみる

事務のお仕事、とりわけ人事給与計算の仕事をしていると、前月のデータと今月のデータをチェックする機会があります。10件程度であれば、目検でチェックでも良いですが、膨大にあり、しかもその種類が多いとなると、それだけでも相当の時間と体力を消費します。しかも、人間はミスをします。

今回のVBAはそれらを解消し、給与計算の定時改定、随時改定、人事異動、住所変更や氏名変更などの様々なマスターデータの変更を一括チェックします。およそ5000件のデータで40秒ほどでチェックが可能です。今回は、VBAで一個ずつ検出して出力する方式と、特定のOfficeのエディションについてくるInquireアドインを使った２パターンを紹介してみようと思います。

1 今回使用するExcelシート
2 使い方
- 2.1 システム要件
- 2.2 チェック手順
3 ソースコード
4 Inquireプラグインを使ってみる
5 関連リンク

今回使用するExcelシート

サンプルデータは、疑似個人情報データ生成サービスを用いて生成しています。生成データを貼り付けてください。また、今回はVBAにて1行ずつ比較していますが、VBAを使わず手っ取り早く相違するデータだけを抽出したい場合は、Power Queryを使うという手段もあります。以下のエントリーを参考に作ってみて下さい。

Power Queryで２つのExcelシートの差分を取り出してみる

図：機能はシンプルに2個だけ

使い方

システム要件

今回のシートは主にマスターデータなどで、２つのシートを比較しその差分を取り出すプログラムです。そのため、以下のルールが存在します。

1列目はID、2列目は名前などの列を用意します。
精査対象のブックの1枚目のシートのみをチェック対象にしています。2枚以上ある場合、そのシートを選ぶことはできません。
1行目は見出しである必要があります。
見出しは基準元も比較先も同じ見出し列の数、見出し名である必要があります。
マスターチェックであるため、基準元も比較先も、例えば同じ人物のデータが複数存在してはいけません。
基準元を基準に、比較先のデータに変更のあるセルは赤字で表示されます。また、比較先にしかないデータは追加シートに、基準元にしかないデータは削除シートに抽出されます。
取り込めるデータは、xls形式、xlsx形式、xlsm形式およびcsv形式です。

チェック手順

2枚の同じようなシートを順番に読み込ませて、チェックを開始します。

差分チェッカー.xlsmを起動する
最初の１回は、「コンテンツの有効化」をクリックします。これは必須です。
コンペア君という専用のタブが出現します。
「2シートデータのインポート」をクリックします。
まずは、基準元データをインポートする。通常は前月のデータを指定します。
つづけて、比較先データをインポートする。通常は今月のデータを指定します。
インポートが完了すると、それぞれ基準元、比較先シートにデータが書き込まれます。
次に、「シートデータの比較検証」をクリックします。
「差分だけ抽出するか？」について、「はい」をクリックすると、差分のあるレコードのみが差分抽出シートに出力されます。また、差分のあるセルだけが書き込まれ、赤字で表示されます。
「いいえ」をクリックすると、差分のあるレコード以外の全ても差分抽出シートに出力されます。この場合、差分のないデータは灰色で表示され、差分のあるセルだけが赤字で表示されます。こちらは、抽出まで時間が掛かります。
完了のダイアログが出たら終了です。
毎回インポート時、シートデータの比較検証時にそれぞれのシートは全クリアされるので、そのまま続けて利用も可能です。
「スペシャル版で差分抽出を行う」にチェックを入れて実行した場合、比較元と比較先の新旧データを並べた状態で、抽出を行います。その為、相応の時間が掛かります。

図：VBAが含まれているのでコンテンツの有効化が必須

図：差分抽出方法の質問ダイアログ

ソースコード

インポートを行うコード

'グローバル配列
Public firstArray, secondArray
Public rRec, cRec, tCol As Variant

'比較対象2シートの取り込みメインルーチン
Public Function twosheetimport()
    '変数の宣言
    Dim dlg As Object, boolResult As Boolean
    Dim ret As Variant
    
    'シートデータの変数
    Dim firstsheet As String
    Dim secondsheet As String

    'オブジェクト変数にFileDialogオブジェクトを代入
    Set dlg = Application.FileDialog(msoFileDialogOpen)
    
    'FileDialogオブジェクトの各種プロパティを設定
    With dlg
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "比較対象Excelブック", "*.xls; *.xlsx; *.xlsm; *.csv"
        .FilterIndex = 3
        .Title = "基準となるシートデータの取り込み"
        .ButtonName = "取り込む"
    End With

    'ファイルを開くダイアログを開く
    boolResult = dlg.Show
    
    If boolResult Then
        'インポートルーチンに渡す
        firstsheet = dlg.SelectedItems(1)
    Else
        '[キャンセル]ボタンが押された場合の処理
        MsgBox "シートデータの取り込みはキャンセルされました。"
        Exit Function
    End If
    
    'FileDialogオブジェクトの各種プロパティを設定
    With dlg
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "比較対象Excelブック", "*.xls; *.xlsx; *.xlsm; *.csv"
        .FilterIndex = 3
        .Title = "比較対象シートデータの取り込み"
        .ButtonName = "取り込む"
    End With
    
    'ファイルを開くダイアログを開く
    boolResult = dlg.Show
    
    If boolResult Then
        'インポートルーチンに渡す
        secondsheet = dlg.SelectedItems(1)
    Else
        '[キャンセル]ボタンが押された場合の処理
        MsgBox "シートデータの取り込みはキャンセルされました。"
        Exit Function
    End If

    '2つのシートデータをまずは順番に取り込み（1シート目だけ対象とする）
    ret = getsheetData(firstsheet, 0)
    ret = getsheetData(secondsheet, 1)
    
    '終了処理
    Set dlg = Nothing
    
    'カラムの数一致チェック
    Dim finalcol As Variant
    Dim finalcol2 As Variant
    Dim aArray, bArray
    Dim j As Variant
    
    'このワークシートをアクティブにする
    ThisWorkbook.Activate
    
    finalcol = Worksheets("基準元").UsedRange.Columns.Count
    finalcol2 = Worksheets("比較先").UsedRange.Columns.Count
    
    If finalcol = finalcol2 Then
    Else
        'カラムの数が異なるよ
        MsgBox "列数が違うみたいですよ"
        Exit Function
    End If
    
    'カラムの同一性チェック
    Worksheets("基準元").Activate
    aArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, finalcol))
    Worksheets("比較先").Activate
    bArray = Worksheets("比較先").Range(Cells(1, 1), Cells(1, finalcol2))
    
    For j = 1 To finalcol
        'カラム名を比較
        If aArray(1, j) = bArray(1, j) Then
        Else
            MsgBox j & "番目のカラム名と違う列がありますよ。"
            Exit Function
        End If
    Next j
    
    '終了処理
    MsgBox "シートデータのインポートが完了しました。"
    
End Function
'シートデータの取り込み
Public Function getsheetData(temppath As String, numflg As Variant) As Variant

    '変数の宣言
    Dim xlsxfile
    Dim WsObj As Object
    Dim MyArray
    Dim lastrow As Variant
    Dim lastColumn As Variant
    Dim FileName As String
    Dim sheetname As String
    
    'scripting runtime
    Dim fso As New Scripting.FileSystemObject
    
    '書き込み先シートデータをクリアする
    Dim kinfinal As Variant
    Dim ginfinal As Variant
    
    'このワークシートをアクティブにする
    ThisWorkbook.Activate
    
    If numflg = 0 Then
        '基準元シートのデータ数をカウント
        kinfinal = ThisWorkbook.Worksheets("基準元").UsedRange.Rows.Count
        
        '基準元シートのカラム数をカウント
        ginfinal = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count
        
        'シートデータをクリアする
        If kinfinal = 1 And ginfinal = 1 Then
        
        Else
            Worksheets("基準元").Activate
            ThisWorkbook.Worksheets("基準元").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
        End If
        
    Else
        '比較先シートのデータ数をカウント
        kinfinal = ThisWorkbook.Worksheets("比較先").UsedRange.Rows.Count
        
        '比較先シートのカラム数をカウント
        ginfinal = ThisWorkbook.Worksheets("比較先").UsedRange.Columns.Count
        
        'シートデータをクリアする
        If kinfinal = 1 And ginfinal = 1 Then
        
        Else
            Worksheets("比較先").Activate
            ThisWorkbook.Worksheets("比較先").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
        End If
    
    End If

    'xlsxファイルの設定関係
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
    'データファイルを開く
    Set xlsxfile = Workbooks.Open(temppath)
    
    'ワークシート1枚目のシート名を特定する
    For Each i In xlsxfile.Sheets
        sheetname = i.Name
        Exit For
    Next i
    
    
    'データシートを開く
    Set WsObj = xlsxfile.Worksheets(CStr(sheetname))

    'データの行数をカウント
    lastrow = WsObj.UsedRange.Rows.Count
    lastColumn = WsObj.UsedRange.Columns.Count
    
    'データ部分を配列で取得する
    WsObj.Activate
    MyArray = WsObj.Range(Cells(1, 1), Cells(lastrow, lastColumn))

    'このワークシートをアクティブにする
    ThisWorkbook.Activate
    
    '取得したデータを洗い替えで勤怠データシートに貼り付ける
    If numflg = 0 Then
        Worksheets("基準元").Activate
        ThisWorkbook.Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn)) = MyArray
    Else
        Worksheets("比較先").Activate
        ThisWorkbook.Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn)) = MyArray
    End If

    'このワークシートをアクティブにする
    ThisWorkbook.Activate

    '終了処理
    xlsxfile.Close
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Set xlsxfile = Nothing
    Set WsObj = Nothing
    Set fso = Nothing
    
    '値を返す
    getsheetData = 1

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

'グローバル配列

Public firstArray, secondArray

Public rRec, cRec, tCol As Variant

'比較対象2シートの取り込みメインルーチン

Public Function twosheetimport()

'変数の宣言

Dim dlg As Object, boolResult As Boolean

Dim ret As Variant

'シートデータの変数

Dim firstsheet As String

Dim secondsheet As String

'オブジェクト変数にFileDialogオブジェクトを代入

Set dlg = Application.FileDialog(msoFileDialogOpen)

'FileDialogオブジェクトの各種プロパティを設定

With dlg

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add "比較対象Excelブック", "*.xls; *.xlsx; *.xlsm; *.csv"

.FilterIndex = 3

.Title = "基準となるシートデータの取り込み"

.ButtonName = "取り込む"

End With

'ファイルを開くダイアログを開く

boolResult = dlg.Show

If boolResult Then

'インポートルーチンに渡す

firstsheet = dlg.SelectedItems(1)

Else

'[キャンセル]ボタンが押された場合の処理

MsgBox "シートデータの取り込みはキャンセルされました。"

Exit Function

End If

'FileDialogオブジェクトの各種プロパティを設定

With dlg

.AllowMultiSelect = False

.Filters.Clear

.Filters.Add "比較対象Excelブック", "*.xls; *.xlsx; *.xlsm; *.csv"

.FilterIndex = 3

.Title = "比較対象シートデータの取り込み"

.ButtonName = "取り込む"

End With

'ファイルを開くダイアログを開く

boolResult = dlg.Show

If boolResult Then

'インポートルーチンに渡す

secondsheet = dlg.SelectedItems(1)

Else

'[キャンセル]ボタンが押された場合の処理

MsgBox "シートデータの取り込みはキャンセルされました。"

Exit Function

End If

'2つのシートデータをまずは順番に取り込み（1シート目だけ対象とする）

ret = getsheetData(firstsheet, 0)

ret = getsheetData(secondsheet, 1)

'終了処理

Set dlg = Nothing

'カラムの数一致チェック

Dim finalcol As Variant

Dim finalcol2 As Variant

Dim aArray, bArray

Dim j As Variant

'このワークシートをアクティブにする

ThisWorkbook.Activate

finalcol = Worksheets("基準元").UsedRange.Columns.Count

finalcol2 = Worksheets("比較先").UsedRange.Columns.Count

If finalcol = finalcol2 Then

Else

'カラムの数が異なるよ

MsgBox "列数が違うみたいですよ"

Exit Function

End If

'カラムの同一性チェック

Worksheets("基準元").Activate

aArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, finalcol))

Worksheets("比較先").Activate

bArray = Worksheets("比較先").Range(Cells(1, 1), Cells(1, finalcol2))

For j = 1 To finalcol

'カラム名を比較

If aArray(1, j) = bArray(1, j) Then

Else

MsgBox j & "番目のカラム名と違う列がありますよ。"

Exit Function

End If

Next j

'終了処理

MsgBox "シートデータのインポートが完了しました。"

End Function

'シートデータの取り込み

Public Function getsheetData(temppath As String, numflg As Variant) As Variant

'変数の宣言

Dim xlsxfile

Dim WsObj As Object

Dim MyArray

Dim lastrow As Variant

Dim lastColumn As Variant

Dim FileName As String

Dim sheetname As String

'scripting runtime

Dim fso As New Scripting.FileSystemObject

'書き込み先シートデータをクリアする

Dim kinfinal As Variant

Dim ginfinal As Variant

'このワークシートをアクティブにする

ThisWorkbook.Activate

If numflg = 0 Then

'基準元シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("基準元").UsedRange.Rows.Count

'基準元シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("基準元").Activate

ThisWorkbook.Worksheets("基準元").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

Else

'比較先シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("比較先").UsedRange.Rows.Count

'比較先シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("比較先").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("比較先").Activate

ThisWorkbook.Worksheets("比較先").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'xlsxファイルの設定関係

Application.ScreenUpdating = False

Application.Calculation = xlManual

'データファイルを開く

Set xlsxfile = Workbooks.Open(temppath)

'ワークシート1枚目のシート名を特定する

For Each i In xlsxfile.Sheets

sheetname = i.Name

Exit For

Next i

'データシートを開く

Set WsObj = xlsxfile.Worksheets(CStr(sheetname))

'データの行数をカウント

lastrow = WsObj.UsedRange.Rows.Count

lastColumn = WsObj.UsedRange.Columns.Count

'データ部分を配列で取得する

WsObj.Activate

MyArray = WsObj.Range(Cells(1, 1), Cells(lastrow, lastColumn))

'このワークシートをアクティブにする

ThisWorkbook.Activate

'取得したデータを洗い替えで勤怠データシートに貼り付ける

If numflg = 0 Then

Worksheets("基準元").Activate

ThisWorkbook.Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn)) = MyArray

Else

Worksheets("比較先").Activate

ThisWorkbook.Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn)) = MyArray

End If

'このワークシートをアクティブにする

ThisWorkbook.Activate

'終了処理

xlsxfile.Close

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Set xlsxfile = Nothing

Set WsObj = Nothing

Set fso = Nothing

'値を返す

getsheetData = 1

End Function

twosheetimport関数がインポートを担当する関数ですが、実際にインポート作業を行う関数は、getsheetdata関数が担当しています。
インポートでは、カラムの数相違のチェック、カラムタイトル行の値の相違チェックの２つを行っています。
それぞれ順番に基準元、比較先のシートにデータを洗い替えでインポートしますので、既存データは完全に空になります。

差分チェックを行うコード

'2シートデータの比較チェックの実行
Public Function comparecheck()
    '変数の宣言
    Dim sabunflg As Boolean

    '問い合わせメッセージ
    Dim rc As Integer
    rc = MsgBox("2つのシートのデータを比較しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理をキャンセルしました。"
        Exit Function
    End If

    '差分だけ抽出するか確認ダイアログ
    rc = MsgBox("差分だけを抽出しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    If rc = vbYes Then
        sabunflg = True
    Else
        sabunflg = False
    End If
    
    '2つのシートデータをグローバル配列に格納する
    Dim lastrow As Variant
    Dim lastColumn As Variant
    
    Worksheets("基準元").Activate
    lastrow = Worksheets("基準元").UsedRange.Rows.Count
    lastColumn = Worksheets("基準元").UsedRange.Columns.Count
    
    firstArray = Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn))
    rRec = lastrow
    tCol = lastColumn
    
    Worksheets("比較先").Activate
    lastrow = Worksheets("比較先").UsedRange.Rows.Count
    lastColumn = Worksheets("比較先").UsedRange.Columns.Count
    
    secondArray = Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn))
    cRec = lastrow

    '差分フラグを見て処理を分岐
    If sabunflg = True Then
        Call sabuninsert(0)
    Else
        Call sabuninsert(1)
    End If
    
    '追加されているデータを抽出して書き込む
    Call addinsert
    
    '終了処理
    MsgBox "データの抽出作業が完了しました。"

End Function
Public Function addinsert()
    '変数を宣言する
    Dim i, j, k As Variant
    Dim checkman As String
    Dim checkman2 As String
    Dim n As Variant
    Dim addflg As Boolean

    '比較先シートを回す
    For j = 2 To cRec
        
        'フリーズ防止用
        DoEvents
        
        '1列目と2列目のデータを取得する
        checkman2 = secondArray(j, 1) & secondArray(j, 2)
        
        '変数を初期化
        addflg = True
        
        '基準元シートを回す
        For i = 2 To rRec
            '1列目と2列目データを取得する
            checkman = firstArray(i, 1) & firstArray(i, 2)
            
            'firstArrayのcheckmanと比較
            If checkman = checkman2 Then
                
                '削除フラグを閉じる
                addflg = False

                '内側のループを抜ける
                Exit For
            
            End If
        Next i
        
        '追加フラグを見てTrueの場合、追加シートにデータを追加
        If addflg = True Then
            '最終行を取得する
            Worksheets("追加").Activate
            n = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
            '配列データを1個ずつチェックする
            For k = 1 To tCol
                With Worksheets("追加")
                    'secondArray側の値を書き込む
                    .Cells(n, k).Value = secondArray(j, k)
                    '文字色を緑色にする
                    .Cells(n, k).Font.Color = &HFF0000
                End With
            Next k
        End If
        
    Next j
    
End Function
'両方のシートの差分だけをシートに書き出す処理
Public Function sabuninsert(allflg As Variant)
    '差分抽出シートをクリアする
    Dim kinfinal As Variant
    Dim ginfinal As Variant
    Dim mArray
    
    '行見出しデータの取得
    Dim kijunf As Variant
    kijunf = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count
    Worksheets("基準元").Activate
    mArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, kijunf))
    
    '差分抽出シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Rows.Count
    '差分抽出シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        Worksheets("差分抽出").Activate
        ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
    End If

    '差分抽出の1行目に見だしを入れる
    Worksheets("差分抽出").Activate
    ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(1, kijunf)) = mArray
    
    
    '削除シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("削除").UsedRange.Rows.Count
    '削除シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("削除").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        Worksheets("削除").Activate
        ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
    End If

    '削除の1行目に見だしを入れる
    Worksheets("削除").Activate
    ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(1, kijunf)) = mArray
    
    
    
    '追加シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("追加").UsedRange.Rows.Count
    '追加シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("追加").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        Worksheets("追加").Activate
        ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
    End If

    '追加の1行目に見だしを入れる
    Worksheets("追加").Activate
    ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(1, kijunf)) = mArray
    
    
    '基準元シートを回し、比較先シートを探索する（1列目と2列目の値をもって特定する）
    Dim i, j, k, d As Variant
    Dim checkman As String
    Dim checkman2 As String
    Dim sabflg As Boolean
    Dim delflg As Boolean
    Dim n, m As Variant
    Dim debugval As Variant
    
    For i = 2 To rRec
        'フリーズ防止用
        DoEvents
    
        '1列目と2列目データを取得する
        checkman = firstArray(i, 1) & firstArray(i, 2)
        
        'フラグを初期化
        sabflg = False
        delflg = True
    
        '比較先シートを回す
        For j = 2 To cRec
            '1列目と2列目のデータを取得する
            checkman2 = secondArray(j, 1) & secondArray(j, 2)
            
            'firstArrayのcheckmanと比較
            If checkman = checkman2 Then
                'IDと名前が一致しているので、差分チェックを行う
                Worksheets("差分抽出").Activate
                
                '削除フラグを閉じる
                delflg = False
                
                '最終行を取得する
                n = Cells(Rows.Count, "A").End(xlUp).Row + 1

                '配列データを1個ずつチェックする
                For k = 3 To tCol
                    '2つの配列を比較して同じ値の場合にはスルーする
                    If firstArray(i, k) = secondArray(j, k) Then
                        If allflg = 0 Then
                            '値は同一なのでスルー
                        Else
                            '全数値表示なので、値を記述させる
                            With Worksheets("差分抽出")
                                'secondArray側の値を書き込む
                                .Cells(n, k).Value = secondArray(j, k)
                                '文字色を灰色にする
                                .Cells(n, k).Font.Color = &H808080
                            End With
                            
                            '差分フラグを立てる
                            sabflg = True
                        End If
                    Else
                        With Worksheets("差分抽出")
                            'secondArray側の値を書き込む
                            .Cells(n, k).Value = secondArray(j, k)
                            '文字色を赤色にする
                            .Cells(n, k).Font.Color = &HFF
                        End With
                        
                        '差分フラグを立てる
                        sabflg = True
                    End If
                Next k
                
                '差分フラグが立ってたら、1列目と2列目を記述する
                If sabflg = True Then
                    With Worksheets("差分抽出")
                        .Cells(n, 1).Value = firstArray(i, 1)
                        .Cells(n, 2).Value = firstArray(i, 2)
                    End With
                End If
            
                '内側のループを抜ける
                Exit For
            End If
        Next j
        
        '削除フラグを見てTrueの場合、削除シートにデータを追加
        If delflg = True Then
            '最終行を取得する
            Worksheets("削除").Activate
            m = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
            '配列データを1個ずつチェックする
            For k = 1 To tCol
                With Worksheets("削除")
                    'secondArray側の値を書き込む
                    .Cells(m, k).Value = firstArray(i, k)
                    '文字色を青色にする
                    .Cells(m, k).Font.Color = &H669933
                End With
            Next k
        End If

    Next i
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

'2シートデータの比較チェックの実行

Public Function comparecheck()

'変数の宣言

Dim sabunflg As Boolean

'問い合わせメッセージ

Dim rc As Integer

rc = MsgBox("2つのシートのデータを比較しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")

If rc = vbYes Then

Else

MsgBox "処理をキャンセルしました。"

Exit Function

End If

'差分だけ抽出するか確認ダイアログ

rc = MsgBox("差分だけを抽出しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")

If rc = vbYes Then

sabunflg = True

Else

sabunflg = False

End If

'2つのシートデータをグローバル配列に格納する

Dim lastrow As Variant

Dim lastColumn As Variant

Worksheets("基準元").Activate

lastrow = Worksheets("基準元").UsedRange.Rows.Count

lastColumn = Worksheets("基準元").UsedRange.Columns.Count

firstArray = Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn))

rRec = lastrow

tCol = lastColumn

Worksheets("比較先").Activate

lastrow = Worksheets("比較先").UsedRange.Rows.Count

lastColumn = Worksheets("比較先").UsedRange.Columns.Count

secondArray = Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn))

cRec = lastrow

'差分フラグを見て処理を分岐

If sabunflg = True Then

Call sabuninsert(0)

Else

Call sabuninsert(1)

End If

'追加されているデータを抽出して書き込む

Call addinsert

'終了処理

MsgBox "データの抽出作業が完了しました。"

End Function

Public Function addinsert()

'変数を宣言する

Dim i, j, k As Variant

Dim checkman As String

Dim checkman2 As String

Dim n As Variant

Dim addflg As Boolean

'比較先シートを回す

For j = 2 To cRec

'フリーズ防止用

DoEvents

'1列目と2列目のデータを取得する

checkman2 = secondArray(j, 1) & secondArray(j, 2)

'変数を初期化

addflg = True

'基準元シートを回す

For i = 2 To rRec

'1列目と2列目データを取得する

checkman = firstArray(i, 1) & firstArray(i, 2)

'firstArrayのcheckmanと比較

If checkman = checkman2 Then

'削除フラグを閉じる

addflg = False

'内側のループを抜ける

Exit For

End If

Next i

'追加フラグを見てTrueの場合、追加シートにデータを追加

If addflg = True Then

'最終行を取得する

Worksheets("追加").Activate

n = Cells(Rows.Count, "A").End(xlUp).Row + 1

'配列データを1個ずつチェックする

For k = 1 To tCol

With Worksheets("追加")

'secondArray側の値を書き込む

.Cells(n, k).Value = secondArray(j, k)

'文字色を緑色にする

.Cells(n, k).Font.Color = &HFF0000

End With

Next k

End If

Next j

End Function

'両方のシートの差分だけをシートに書き出す処理

Public Function sabuninsert(allflg As Variant)

'差分抽出シートをクリアする

Dim kinfinal As Variant

Dim ginfinal As Variant

Dim mArray

'行見出しデータの取得

Dim kijunf As Variant

kijunf = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count

Worksheets("基準元").Activate

mArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, kijunf))

'差分抽出シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Rows.Count

'差分抽出シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("差分抽出").Activate

ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'差分抽出の1行目に見だしを入れる

Worksheets("差分抽出").Activate

ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

'削除シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("削除").UsedRange.Rows.Count

'削除シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("削除").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("削除").Activate

ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'削除の1行目に見だしを入れる

Worksheets("削除").Activate

ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

'追加シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("追加").UsedRange.Rows.Count

'追加シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("追加").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("追加").Activate

ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'追加の1行目に見だしを入れる

Worksheets("追加").Activate

ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

'基準元シートを回し、比較先シートを探索する（1列目と2列目の値をもって特定する）

Dim i, j, k, d As Variant

Dim checkman As String

Dim checkman2 As String

Dim sabflg As Boolean

Dim delflg As Boolean

Dim n, m As Variant

Dim debugval As Variant

For i = 2 To rRec

'フリーズ防止用

DoEvents

'1列目と2列目データを取得する

checkman = firstArray(i, 1) & firstArray(i, 2)

'フラグを初期化

sabflg = False

delflg = True

'比較先シートを回す

For j = 2 To cRec

'1列目と2列目のデータを取得する

checkman2 = secondArray(j, 1) & secondArray(j, 2)

'firstArrayのcheckmanと比較

If checkman = checkman2 Then

'IDと名前が一致しているので、差分チェックを行う

Worksheets("差分抽出").Activate

'削除フラグを閉じる

delflg = False

'最終行を取得する

n = Cells(Rows.Count, "A").End(xlUp).Row + 1

'配列データを1個ずつチェックする

For k = 3 To tCol

'2つの配列を比較して同じ値の場合にはスルーする

If firstArray(i, k) = secondArray(j, k) Then

If allflg = 0 Then

'値は同一なのでスルー

Else

'全数値表示なので、値を記述させる

With Worksheets("差分抽出")

'secondArray側の値を書き込む

.Cells(n, k).Value = secondArray(j, k)

'文字色を灰色にする

.Cells(n, k).Font.Color = &H808080

End With

'差分フラグを立てる

sabflg = True

End If

Else

With Worksheets("差分抽出")

'secondArray側の値を書き込む

.Cells(n, k).Value = secondArray(j, k)

'文字色を赤色にする

.Cells(n, k).Font.Color = &HFF

End With

'差分フラグを立てる

sabflg = True

End If

Next k

'差分フラグが立ってたら、1列目と2列目を記述する

If sabflg = True Then

With Worksheets("差分抽出")

.Cells(n, 1).Value = firstArray(i, 1)

.Cells(n, 2).Value = firstArray(i, 2)

End With

End If

'内側のループを抜ける

Exit For

End If

Next j

'削除フラグを見てTrueの場合、削除シートにデータを追加

If delflg = True Then

'最終行を取得する

Worksheets("削除").Activate

m = Cells(Rows.Count, "A").End(xlUp).Row + 1

'配列データを1個ずつチェックする

For k = 1 To tCol

With Worksheets("削除")

'secondArray側の値を書き込む

.Cells(m, k).Value = firstArray(i, k)

'文字色を青色にする

.Cells(m, k).Font.Color = &H669933

End With

Next k

End If

Next i

End Function

comparecheck関数が差分チェックを担当する関数ですが、実際に差分検出作業を行うのは、sabuninsert関数です。
差分チェックでは、差分のあるレコードだけ表示するか？差分のないレコードも表示するか？をsabunflgでもって分岐させています。
データは配列の塊に対して行われます。書き込みは１行単位で書き込みを行っています。
addinsert関数は、比較先で追加されたレコードがあるものを検出して、追加シートへ記述する為の関数です。
sabuninsert関数ではそれぞれのシートのクリア、行見出しの設定なども行っています。
sabuninsert関数では比較先で削除されているレコードの検出も兼務しています。
差分データは赤字で出力されます。差分のないレコードについては灰色で出力されます。
差分チェック自体は、メモリ上に確保した配列データをループで回し、１個ずつ比較しては書き込みを行っています。フォントカラーだけ別に配列を用意できれば、すべてをオンメモリで一発書き込みも可能だと思います。高速化も期待できます。

より高度な差分チェックを行うコード

「スペシャル版で差分抽出を行う」のチェックボックスがリボンにありますが、このオプションを利用した場合の処理は、新旧両方の値を並べる機能として追加実装しています。このオプションはデフォルトでFalseですが、チェックを入れた場合には別のコードで処理をするようになっています。また、動的にリボンの値を取得する必要があるので、リボンにもコードの追加がなされています。

リボンのコード

'データ書き込みカウンタやフラグ
Private flgChk As Boolean

'チェックボックスの状態を格納する
Public isCheckBox As Boolean

 
'リボン起動時に初期化するコード
Public Sub OnLoad(ribbon As IRibbonUI)
    'リボンのインスタンスを取得
    Set m_ribbon = ribbon
 
    '自作のリボンをアクティブにする
    m_ribbon.ActivateTab ("macroman")
    
    'チェックボックスの初期値設定
    flgChk = False 'checkBox要素の初期値
    
End Sub

Public Sub chkSample_getPressed(control As IRibbonControl, ByRef returnedVal)
  'checkBox要素のON・OFFを設定
  'http://fnya.cocolog-nifty.com/blog/2014/02/vba-f831.html
  returnedVal = flgChk
  
  'チェックボックスの初期値を格納
  isCheckBox = flgChk
  
End Sub

'チェックボックスをクリックした時の動作
'https://www.ka-net.org/blog/?p=5240
Public Sub chkSample_onAction(control As IRibbonControl, pressed As Boolean)
'checkBox要素クリック時に実行
  flgChk = Not flgChk
  
  'pressedの判定を行う
  If pressed = True Then
    MsgBox "比較前列と比較後列の2つを並べて表示するように抽出します", vbSystemModal
  Else
    MsgBox "通常通り変更箇所だけを抽出して表示するように抽出します", vbSystemModal
  End If
  
  'チェックボックスの状態を格納する
  isCheckBox = pressed

End Sub

'データ書き込みカウンタやフラグ

Private flgChk As Boolean

'チェックボックスの状態を格納する

Public isCheckBox As Boolean

'リボン起動時に初期化するコード

Public Sub OnLoad(ribbon As IRibbonUI)

'リボンのインスタンスを取得

Set m_ribbon = ribbon

'自作のリボンをアクティブにする

m_ribbon.ActivateTab ("macroman")

'チェックボックスの初期値設定

flgChk = False 'checkBox要素の初期値

End Sub

Public Sub chkSample_getPressed(control As IRibbonControl, ByRef returnedVal)

'checkBox要素のON・OFFを設定

'http://fnya.cocolog-nifty.com/blog/2014/02/vba-f831.html

returnedVal = flgChk

'チェックボックスの初期値を格納

isCheckBox = flgChk

End Sub

'チェックボックスをクリックした時の動作

'https://www.ka-net.org/blog/?p=5240

Public Sub chkSample_onAction(control As IRibbonControl, pressed As Boolean)

'checkBox要素クリック時に実行

flgChk = Not flgChk

'pressedの判定を行う

If pressed = True Then

MsgBox "比較前列と比較後列の2つを並べて表示するように抽出します", vbSystemModal

Else

MsgBox "通常通り変更箇所だけを抽出して表示するように抽出します", vbSystemModal

End If

'チェックボックスの状態を格納する

isCheckBox = pressed

End Sub

メインの処理コード

'2シートデータの比較チェックの実行
Public Function comparecheck()
    '変数の宣言
    Dim sabunflg As Boolean

    '問い合わせメッセージ
    Dim rc As Integer
    rc = MsgBox("2つのシートのデータを比較しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    If rc = vbYes Then
    Else
        MsgBox "処理をキャンセルしました。"
        Exit Function
    End If

    '差分だけ抽出するか確認ダイアログ
    rc = MsgBox("差分だけを抽出しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")
    If rc = vbYes Then
        sabunflg = True
    Else
        sabunflg = False
    End If
    
    '2つのシートデータをグローバル配列に格納する
    Dim lastrow As Variant
    Dim lastColumn As Variant
    
    Worksheets("基準元").Activate
    lastrow = Worksheets("基準元").UsedRange.Rows.Count
    lastColumn = Worksheets("基準元").UsedRange.Columns.Count
    
    firstArray = Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn))
    rRec = lastrow
    tCol = lastColumn
    
    Worksheets("比較先").Activate
    lastrow = Worksheets("比較先").UsedRange.Rows.Count
    lastColumn = Worksheets("比較先").UsedRange.Columns.Count
    
    secondArray = Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn))
    cRec = lastrow

    '差分フラグを見て処理を分岐
    Debug.Print isCheckBox
    If isCheckBox = True Then
        '変更前と変更後の2つを並べて表示するモード
        If sabunflg = True Then
            Call checkinsert(0)
        Else
            Call checkinsert(1)
        End If
    Else
        '通常の変更箇所だけの抽出を行う
        If sabunflg = True Then
            Call sabuninsert(0)
        Else
            Call sabuninsert(1)
        End If
    End If
    
    '追加されているデータを抽出して書き込む
    Call addinsert
    
    '終了処理
    MsgBox "データの抽出作業が完了しました。"

End Function

'両方のシートの差分を比較前と後で並べて書き出す処理
Public Function checkinsert(allflg As Variant)
    '差分抽出シートをクリアする
    Dim kinfinal As Variant
    Dim ginfinal As Variant
    Dim mArray
    
    '行見出しデータの取得
    Dim kijunf As Variant
    kijunf = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count
    Worksheets("基準元").Activate
    mArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, kijunf))
    
    '差分抽出シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Rows.Count
    '差分抽出シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        '差分抽出シートをクリアする
        Worksheets("差分抽出").Activate
        ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
        
        '差分抽出シートのウィンドウ枠固定を解除
        Worksheets("差分抽出").Range("C2").Select
        ActiveWindow.FreezePanes = False
        
    End If

    '差分抽出の1行目に見だしを入れる
    Dim malength As Variant
    Dim t As Variant
    Dim cnt As Variant  '列カウンタ
    malength = UBound(mArray, 2)  '配列の要素数を取得する
    cnt = 1
    
    For t = 1 To malength
        
        If t = 1 Or t = 2 Then
            '1個目と2個目は普通にシートに書き込む
            Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t)
        Else
            '他の列を2回ずつ名前を変えて書き込み
            Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t) & "(B)"
            
            cnt = cnt + 1
            
            Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t) & "(A)"

        End If
    
        '列カウンタを回す
        cnt = cnt + 1
    
    Next t

    '削除シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("削除").UsedRange.Rows.Count
    '削除シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("削除").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        Worksheets("削除").Activate
        ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
    End If

    '削除の1行目に見だしを入れる
    Worksheets("削除").Activate
    ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

    '追加シートのデータ数をカウント
    kinfinal = ThisWorkbook.Worksheets("追加").UsedRange.Rows.Count
    '追加シートのカラム数をカウント
    ginfinal = ThisWorkbook.Worksheets("追加").UsedRange.Columns.Count

    'シートデータをクリアする
    If kinfinal = 1 And ginfinal = 1 Then
    Else
        Worksheets("追加").Activate
        ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear
    End If

    '追加の1行目に見だしを入れる
    Worksheets("追加").Activate
    ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(1, kijunf)) = mArray
    
    '基準元シートを回し、比較先シートを探索する（1列目と2列目の値をもって特定する）
    Dim i, j, k, d As Variant
    Dim checkman As String
    Dim checkman2 As String
    Dim sabflg As Boolean
    Dim delflg As Boolean
    Dim n, m As Variant
    Dim debugval As Variant
    cnt = 3   'カウンタ初期化
    
    For i = 2 To rRec
        'フリーズ防止用
        DoEvents
    
        '1列目と2列目データを取得する
        checkman = firstArray(i, 1) & firstArray(i, 2)
        
        'フラグを初期化
        sabflg = False
        delflg = True
        
        'カウンタを初期化
        cnt = 3
        
        
        '比較先シートを回す
        For j = 2 To cRec
            '1列目と2列目のデータを取得する
            checkman2 = secondArray(j, 1) & secondArray(j, 2)
    
    
            'firstArrayのcheckmanと比較
            If checkman = checkman2 Then
                'IDと名前が一致しているので、差分チェックを行う
                Worksheets("差分抽出").Activate
                
                '削除フラグを閉じる
                delflg = False
                
                '最終行を取得する
                n = Cells(Rows.Count, "A").End(xlUp).Row + 1
                
                '配列データを1個ずつチェックする
                For k = 3 To tCol
                    '2つの配列を比較して同じ値の場合にはスルーする
                    If firstArray(i, k) = secondArray(j, k) Then
                        If allflg = 0 Then
                            '書き込みをスルーし、カウンタを回す
                            cnt = cnt + 2
                        Else
                            '全数値表示なので、値を記述させる
                            With Worksheets("差分抽出")
                                'firstArray側の値を書き込む
                                .Cells(n, cnt).Value = firstArray(i, k)
                                '文字色を灰色にする
                                .Cells(n, cnt).Font.Color = &H808080
                                
                                'カウンタを回す
                                cnt = cnt + 1
                                
                                'secondArray側の値を書き込む
                                .Cells(n, cnt).Value = secondArray(j, k)
                                '文字色を灰色にする
                                .Cells(n, cnt).Font.Color = &H808080
                                
                                'カウンタを回す
                                cnt = cnt + 1
                                
                            End With
                            
                            '差分フラグを立てる
                            sabflg = True
                        End If
                    Else
                        With Worksheets("差分抽出")
                            'firstArray側の値を書き込む
                            .Cells(n, cnt).Value = firstArray(i, k)
                            '文字色を灰色にする
                            .Cells(n, cnt).Font.Color = &H808080
                            
                            'カウンターを回す
                            cnt = cnt + 1
                            
                            'secondArray側の値を書き込む
                            .Cells(n, cnt).Value = secondArray(j, k)
                            '文字色を赤色にする
                            .Cells(n, cnt).Font.Color = &HFF
                            
                            'カウンタを回す
                            cnt = cnt + 1

                        End With
                        
                        '差分フラグを立てる
                        sabflg = True
                    End If
                Next k
    
                '差分フラグが立ってたら、1列目と2列目を記述する
                If sabflg = True Then
                    With Worksheets("差分抽出")
                        .Cells(n, 1).Value = firstArray(i, 1)
                        .Cells(n, 2).Value = firstArray(i, 2)
                    End With
                End If
                
                '内側のループを抜ける
                Exit For
            End If
        Next j

        '削除フラグを見てTrueの場合、削除シートにデータを追加
        If delflg = True Then
            '最終行を取得する
            Worksheets("削除").Activate
            m = Cells(Rows.Count, "A").End(xlUp).Row + 1
    
            '配列データを1個ずつチェックする
            For k = 1 To tCol
                With Worksheets("削除")
                    'secondArray側の値を書き込む
                    .Cells(m, k).Value = firstArray(i, k)
                    '文字色を赤色にする
                    .Cells(m, k).Font.Color = &H669933
                End With
            Next k
        End If

    Next i

    '差分抽出シートのウィンドウ枠固定を設定
    Worksheets("差分抽出").Activate
    Worksheets("差分抽出").Range("C2").Select
    ActiveWindow.FreezePanes = True

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

'2シートデータの比較チェックの実行

Public Function comparecheck()

'変数の宣言

Dim sabunflg As Boolean

'問い合わせメッセージ

Dim rc As Integer

rc = MsgBox("2つのシートのデータを比較しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")

If rc = vbYes Then

Else

MsgBox "処理をキャンセルしました。"

Exit Function

End If

'差分だけ抽出するか確認ダイアログ

rc = MsgBox("差分だけを抽出しますか？", vbYesNo + vbQuestion + vbDefaultButton2, "確認")

If rc = vbYes Then

sabunflg = True

Else

sabunflg = False

End If

'2つのシートデータをグローバル配列に格納する

Dim lastrow As Variant

Dim lastColumn As Variant

Worksheets("基準元").Activate

lastrow = Worksheets("基準元").UsedRange.Rows.Count

lastColumn = Worksheets("基準元").UsedRange.Columns.Count

firstArray = Worksheets("基準元").Range(Cells(1, 1), Cells(lastrow, lastColumn))

rRec = lastrow

tCol = lastColumn

Worksheets("比較先").Activate

lastrow = Worksheets("比較先").UsedRange.Rows.Count

lastColumn = Worksheets("比較先").UsedRange.Columns.Count

secondArray = Worksheets("比較先").Range(Cells(1, 1), Cells(lastrow, lastColumn))

cRec = lastrow

'差分フラグを見て処理を分岐

Debug.Print isCheckBox

If isCheckBox = True Then

'変更前と変更後の2つを並べて表示するモード

If sabunflg = True Then

Call checkinsert(0)

Else

Call checkinsert(1)

End If

Else

'通常の変更箇所だけの抽出を行う

If sabunflg = True Then

Call sabuninsert(0)

Else

Call sabuninsert(1)

End If

'追加されているデータを抽出して書き込む

Call addinsert

'終了処理

MsgBox "データの抽出作業が完了しました。"

End Function

'両方のシートの差分を比較前と後で並べて書き出す処理

Public Function checkinsert(allflg As Variant)

'差分抽出シートをクリアする

Dim kinfinal As Variant

Dim ginfinal As Variant

Dim mArray

'行見出しデータの取得

Dim kijunf As Variant

kijunf = ThisWorkbook.Worksheets("基準元").UsedRange.Columns.Count

Worksheets("基準元").Activate

mArray = Worksheets("基準元").Range(Cells(1, 1), Cells(1, kijunf))

'差分抽出シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Rows.Count

'差分抽出シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("差分抽出").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

'差分抽出シートをクリアする

Worksheets("差分抽出").Activate

ThisWorkbook.Worksheets("差分抽出").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

'差分抽出シートのウィンドウ枠固定を解除

Worksheets("差分抽出").Range("C2").Select

ActiveWindow.FreezePanes = False

End If

'差分抽出の1行目に見だしを入れる

Dim malength As Variant

Dim t As Variant

Dim cnt As Variant '列カウンタ

malength = UBound(mArray, 2) '配列の要素数を取得する

cnt = 1

For t = 1 To malength

If t = 1 Or t = 2 Then

'1個目と2個目は普通にシートに書き込む

Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t)

Else

'他の列を2回ずつ名前を変えて書き込み

Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t) & "(B)"

cnt = cnt + 1

Worksheets("差分抽出").Cells(1, cnt).Value = mArray(1, t) & "(A)"

End If

'列カウンタを回す

cnt = cnt + 1

Next t

'削除シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("削除").UsedRange.Rows.Count

'削除シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("削除").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("削除").Activate

ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'削除の1行目に見だしを入れる

Worksheets("削除").Activate

ThisWorkbook.Worksheets("削除").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

'追加シートのデータ数をカウント

kinfinal = ThisWorkbook.Worksheets("追加").UsedRange.Rows.Count

'追加シートのカラム数をカウント

ginfinal = ThisWorkbook.Worksheets("追加").UsedRange.Columns.Count

'シートデータをクリアする

If kinfinal = 1 And ginfinal = 1 Then

Else

Worksheets("追加").Activate

ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(kinfinal, ginfinal)).Clear

End If

'追加の1行目に見だしを入れる

Worksheets("追加").Activate

ThisWorkbook.Worksheets("追加").Range(Cells(1, 1), Cells(1, kijunf)) = mArray

'基準元シートを回し、比較先シートを探索する（1列目と2列目の値をもって特定する）

Dim i, j, k, d As Variant

Dim checkman As String

Dim checkman2 As String

Dim sabflg As Boolean

Dim delflg As Boolean

Dim n, m As Variant

Dim debugval As Variant

cnt = 3 'カウンタ初期化

For i = 2 To rRec

'フリーズ防止用

DoEvents

'1列目と2列目データを取得する

checkman = firstArray(i, 1) & firstArray(i, 2)

'フラグを初期化

sabflg = False

delflg = True

'カウンタを初期化

cnt = 3

'比較先シートを回す

For j = 2 To cRec

'1列目と2列目のデータを取得する

checkman2 = secondArray(j, 1) & secondArray(j, 2)

'firstArrayのcheckmanと比較

If checkman = checkman2 Then

'IDと名前が一致しているので、差分チェックを行う

Worksheets("差分抽出").Activate

'削除フラグを閉じる

delflg = False

'最終行を取得する

n = Cells(Rows.Count, "A").End(xlUp).Row + 1

'配列データを1個ずつチェックする

For k = 3 To tCol

'2つの配列を比較して同じ値の場合にはスルーする

If firstArray(i, k) = secondArray(j, k) Then

If allflg = 0 Then

'書き込みをスルーし、カウンタを回す

cnt = cnt + 2

Else

'全数値表示なので、値を記述させる

With Worksheets("差分抽出")

'firstArray側の値を書き込む

.Cells(n, cnt).Value = firstArray(i, k)

'文字色を灰色にする

.Cells(n, cnt).Font.Color = &H808080

'カウンタを回す

cnt = cnt + 1

'secondArray側の値を書き込む

.Cells(n, cnt).Value = secondArray(j, k)

'文字色を灰色にする

.Cells(n, cnt).Font.Color = &H808080

'カウンタを回す

cnt = cnt + 1

End With

'差分フラグを立てる

sabflg = True

End If

Else

With Worksheets("差分抽出")

'firstArray側の値を書き込む

.Cells(n, cnt).Value = firstArray(i, k)

'文字色を灰色にする

.Cells(n, cnt).Font.Color = &H808080

'カウンターを回す

cnt = cnt + 1

'secondArray側の値を書き込む

.Cells(n, cnt).Value = secondArray(j, k)

'文字色を赤色にする

.Cells(n, cnt).Font.Color = &HFF

'カウンタを回す

cnt = cnt + 1

End With

'差分フラグを立てる

sabflg = True

End If

Next k

'差分フラグが立ってたら、1列目と2列目を記述する

If sabflg = True Then

With Worksheets("差分抽出")

.Cells(n, 1).Value = firstArray(i, 1)

.Cells(n, 2).Value = firstArray(i, 2)

End With

End If

'内側のループを抜ける

Exit For

End If

Next j

'削除フラグを見てTrueの場合、削除シートにデータを追加

If delflg = True Then

'最終行を取得する

Worksheets("削除").Activate

m = Cells(Rows.Count, "A").End(xlUp).Row + 1

'配列データを1個ずつチェックする

For k = 1 To tCol

With Worksheets("削除")

'secondArray側の値を書き込む

.Cells(m, k).Value = firstArray(i, k)

'文字色を赤色にする

.Cells(m, k).Font.Color = &H669933

End With

Next k

End If

Next i

'差分抽出シートのウィンドウ枠固定を設定

Worksheets("差分抽出").Activate

Worksheets("差分抽出").Range("C2").Select

ActiveWindow.FreezePanes = True

End Function

リボンのチェックボックスの値は起動時にfalseで初期化。チェック時にオンオフ状態をグローバル変数に格納しています。
見出しの行については、比較前に(B)、比較後に(A)と列名を付与しています。
通常モードとの差はcntにて同じ位置のレコードを比較前と比較後のそれぞれのテーブルから値を書き込みしている点です。
また、何も書き込まないケースでもループを2回回して上げないと、書込位置がずれるので、そのようにしています。

Inquireプラグインを使ってみる

実は、Office Professional PlusおよびMicrosoft365 Professional Plusにだけ、Microsoft公式の差分チェッカーアドインが用意されています（実際には、差分チェックだけではなく、参照先チェックなどいろいろな機能が詰まってます）。このアドインはデフォルトでオフにされており、有効にしないと使えません。よって、通常のOfficeや単体パッケージを購入した場合、この差分チェッカーは使えないということです。

図：特定のバージョンじゃないと使えないのです

アドインを有効にする

指定のエディションであれば、既に初めからExcel側にはインストール済みです。しかし、デフォルトでオンにはなっていないので、オンにしてあげる必要があります。また、オンにする為には、「開発タブ」を表示してあげなければならないので、ちょっと手間です。

適当にExcelをまずは起動する
メニューより「ファイル」⇒「オプション」を開く
左サイドメニューの中の「リボンのユーザ設定」をクリック
右サイドにあるチェックボックスのあるエリアに於いて、「開発」を探し、チェックを入れる
OKボタンを押して閉じる。これでExcelに「開発」というタブが表示されます。
次に、その開発タブを開きます。
「COMアドイン」という項目があるので、これをクリックします。
リストの中に「Inquire」というものがあるので、チェックを入れて、OKボタンを押します。
これでさらにExcelに「検査」というタブが表示されるようになります。

図：開発タブをまずは表示しなければならない

図：Inquireアドインを有効にする

アドインの使い方

今回は２つのファイルを比較してみたいと思います。今回のサンプルであるtestdata1.xlsxおよびtestdata2.xlsxを立ち上げておきます。比較にはtestdata1.xlsx、比較対象にはtestdata2.xlsxを指定しておきます。

対象となる２つのブックを開いた状態にしておきます。
検査タブを開き、「ファイルを比較」をクリックします。
ダイアログにおいて、比較には基準元になるファイルを、比較先には比較対象となるファイルを指定します。基準元は通常前月のファイル、比較先は通常は今月のファイルです。
比較ボタンをクリックする
比較結果が専用の画面で表示されます。ただし、英語表記なのでちょっと使いづらいかも。

図：正しく比較するファイルを指定しましょう

図：比較結果画面。正直、見づらい・・・・

比較結果の見方

比較結果は、中央下の画面に出てきます。非常に細かい分類で出てくるので、読み方が必要です。それぞれの検出結果をクリックすると対象の場所に、ジャンプする仕組みになっています。

赤字でAdded Rowsは比較先にだけある追加されたレコードを意味します。
赤字でDeleted Rowsは比較先では削除されているレコードを意味します。
緑字でEntered Value Changedは、比較先で変更されているセルを意味します。
緑字でEntered Value Addedは、空だったセルに比較先で追記されているセルを意味します。
緑字でEntered Value Deletedは、値が入っていたセルが空にされているセルを意味します。
緑字でCell Formatting Changedは、セルの書式設定が変更されているセルを意味します。

他にも、左下に検出項目の凡例がありますが、非常に細かく検出が可能です。タブにあるExport Resultsをクリックすると、検出結果のエクスポートが可能ですが、実務ではあまり役に立たないかなぁ。ただ、VBAで組んだ検出よりも高速に細かく検出が可能なのは素晴らしいと思います。

図：比較結果がExcelでも出力できる