VBAにて２つのExcelシートの差分を取り出してみる
事務のお仕事、とりわけ人事給与計算の仕事をしていると、前月のデータと今月のデータをチェックする機会があります。10件程度であれば、目検でチェックでも良いですが、膨大にあり、しかもその種類が多いとなると、それだけでも相当の時間と体力を消費します。しかも、人間はミスをします。
今回のVBAはそれらを解消し、給与計算の定時改定、随時改定、人事異動、住所変更や氏名変更などの様々なマスターデータの変更を一括チェックします。およそ5000件のデータで40秒ほどでチェックが可能です。今回は、VBAで一個ずつ検出して出力する方式と、特定のOfficeのエディションについてくるInquireアドインを使った２パターンを紹介してみようと思います。
リンク
目次
今回使用するExcelシート
サンプルデータは、疑似個人情報データ生成サービスを用いて生成しています。生成データを貼り付けてください。また、今回はVBAにて1行ずつ比較していますが、VBAを使わず手っ取り早く相違するデータだけを抽出したい場合は、Power Queryを使うという手段もあります。以下のエントリーを参考に作ってみて下さい。
図：機能はシンプルに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
- 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
- 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
メインの処理コード
'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
- リボンのチェックボックスの値は起動時に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でも出力できる
こんにちは
エクセルの比較処理に苦慮して色々探しているうちにこのサイトに辿り着きました。
素敵なツールだと思い早速DLして使ってみたのですが、インポートが下記エラーでできませんでした。
「エラー91 オブジェクト変数またはWithブロック変数が設定されていません」
VBのコードを見てみましたが恥ずかしながら理解するには時間がかかりそうです。
原因を教えていただけると助かります。
使用環境
エクセル v16.36
OSX
よろしくお願い致します。
差分抽出の方法を探していた時にこのサイトに出会いました。
コードを確認していく内に「こんな書き方もあるのか」と目から鱗でした。
記載されたコードを参考に差分抽出ツールを作成することが出来ました。
助かりました。
ありがとうございました。
ナベ様
それは良かったです。このコードは、件数がより多い場合は、配列を用意して配列で一発書き込みするように変更すれば
より早く動くようになるので
よければ挑戦してみてください。
※現在のコードは、１セルずつ書き込みです。