前回、ユーザーフォームを用いて、Excelブック名、Excelシート名を選択し、差分を比較するというVBAを作成しました。
今回は、比較したいエクセルのファイル名、シート名がある程度決まっている場合に、いちいちドロップダウンリストから選択して差分比較を実行するのではなく、ボタン一つで指定ファイルの差分比較を行う実装をしてみました。
フォルダパスにnewとoldという2つのディレクトリを切り、それぞれに差分比較を行いたいファイルを配置します。
aファイルはnewとoldで適当に差分のあるSheetaを用意しました。
bファイルはnew、oldともにSheetを非表示にして、ファイルに差分を付けました。
cファイルはnew,oldとも同一ファイルで差分はありません。
↓こちらがその実行結果です。
差分があるファイルは差分のあるセルの背景を水色にしています。
ちなみにbファイルはシート非表示にしていましたが、シートが表示状態になっています。
また、oldフォルダのシート名の先頭に「old_」がついてリネイムされています。
これは、newフォルダの比較対象ファイルとnewファイルの比較対象ファイル名が同一であった場合に、2つのファイルを同時に開いて差分比較をすることができないための処置となります。
Private Sub CommandButton4_Click()
On Error Resume Next
Dim f1 As String
Dim f2 As String
Dim f3 As String
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim fso As FileSystemObject
Dim nFolder As String
Dim oFolder As String
'フォルダパス
nFolder = ThisWorkbook.Path & "\new\"
oFolder = ThisWorkbook.Path & "\old\"
'ファイル名定義
f1 = "*a.xlsx"
f2 = "*b.xlsx"
f3 = "*c.xlsx"
Dim arrF() As Variant
arrF = Array(f1, f2, f3)
'シート名定義
s1 = "Sheeta"
s2 = "Sheetb"
s3 = "Sheetc"
'ファイル数カウント
Dim fall As String
Dim i As Long
Dim j As Long
Dim cnt As Long
Dim tmp As String
fall = "*"
i = 0
tmp = Dir(nFolder & fall)
Do While tmp <> ""
i = i + 1
tmp = Dir()
Loop
j = 0
tmp = Dir(oFolder & fall)
Do While tmp <> ""
j = j + 1
tmp = Dir()
Loop
If i > j Then
cnt = i
Else
cnt = j
End If
Dim nF As String
Dim oF As String
For Each Var In arrF
Dim s As String
'シート名を指定
If Var = f1 Then
s = s1
ElseIf Var = f2 Then
s = s2
ElseIf Var = f3 Then
s = s3
End If
nF = Dir(nFolder & Var)
oF = Dir(oFolder & Var)
'書込み準備
Dim lline As Integer
Dim sheetName As String
sheetName = ActiveSheet.Name
lline = ThisWorkbook.Worksheets(sheetName).Cells(Rows.Count, 11).End(xlUp).Row
'ファイルがない場合
If nF = "" Or oF = "" Then
ThisWorkbook.Worksheets(sheetName).Cells(lline + 1, 11) = Now & " ファイルがありません → " & Var
GoTo Continue
Else
'ファイル名変換
If nF = oF Then
Dim F As File
Set fso = New FileSystemObject
Set F = fso.GetFile(oFolder & oF)
F.Name = "old_" & F.Name
oF = F.Name
Set fso = Nothing
End If
Dim nBook As Workbook
Dim oBook As Workbook
Dim isDiff As Integer
Dim r As Range
Set nBook = Workbooks.Open(nFolder & nF)
Set oBook = Workbooks.Open(oFolder & oF)
If nBook.Sheets(s).Name = "" Or oBook.Sheets(s).Name = "" Then
ThisWorkbook.Worksheets(sheetName).Cells(lline + 1, 11) = Now & " シートがありません → " & Var & " : " & s
GoTo Continue
End If
'非表示シートを再表示
nBook.Sheets(s).Visible = True
oBook.Sheets(s).Visible = True
nBook.Sheets(s).Activate
oBook.Sheets(s).Activate
'セル背景を無色にする
nBook.Sheets(s).Cells.Interior.ColorIndex = xlNone
oBook.Sheets(s).Cells.Interior.ColorIndex = xlNone
'差分確認
isDiff = 0
For Each r In nBook.Sheets(s).UsedRange
If r <> oBook.Sheets(s).Range(r.Address) Then
r.Interior.ColorIndex = 34
oBook.Sheets(s).Range(r.Address).Interior.ColorIndex = 34
isDiff = 1
End If
Next
For Each r In oBook.Sheets(s).UsedRange
If r <> nBook.Sheets(s).Range(r.Address) Then
r.Interior.ColorIndex = 34
nBook.Sheets(s).Range(r.Address).Interior.ColorIndex = 34
isDiff = 1
End If
Next
'差分ファイル名書き出し
If isDiff = 1 Then
ThisWorkbook.Worksheets(sheetName).Cells(lline + 1, 11) = Now & " 差分があります → " & Var
Else
ThisWorkbook.Worksheets(sheetName).Cells(lline + 1, 11) = Now & " 差分がありません → " & Var
End If
End If
Continue:
'ブックを保存して閉じる
nBook.Save
oBook.Save
nBook.Close
oBook.Close
'ファイル数だけFor Eachを回す
If cnt = 0 Then
Exit For
Else
cnt = cnt - 1
End If
Next Var
End Subコメントアウトにあるファイル名定義とシート名定義はnewフォルダとoldフォルダにある比較したいファイル名、シート名を変数に格納します。ファイル名はワイルドカードで指定していますが、ファイル名はフォルダ内で一意になる名称であり、基本的にnewフォルダとoldフォルダの比較対象ファイル名は同一のものであると想定しています。
ファイル数カウントでフォルダ内にあるファイルの数を調べます。そのファイル数分、For Eachをループさせています。
指定されたファイルやシートが存在しない場合は、以下の処理をスキップし、次のループに入ります。
ファイル名をワイルドカードで指定し、ヒットするファイルが同一フォルダが複数存在する場合、一番最初にヒットしたファイル同士のみが比較差分されるため注意が必要です。また、シート名をワイルドカードで指定することはできません。
コメント