VBA 複数Bookの差分比較自動化を考える

その他

前回、ユーザーフォームを用いて、Excelブック名、Excelシート名を選択し、差分を比較するというVBAを作成しました。

今回は、比較したいエクセルのファイル名、シート名がある程度決まっている場合に、いちいちドロップダウンリストから選択して差分比較を実行するのではなく、ボタン一つで指定ファイルの差分比較を行う実装をしてみました。

フォルダパスにnewとoldという2つのディレクトリを切り、それぞれに差分比較を行いたいファイルを配置します。

newフォルダ aファイル
oldフォルダ aファイル

aファイルはnewとoldで適当に差分のあるSheetaを用意しました。

bファイルはnew、oldともにSheetを非表示にして、ファイルに差分を付けました。

cファイルはnew,oldとも同一ファイルで差分はありません。

↓こちらがその実行結果です。

VBA エクセルBook間の差分比較 自動化
newフォルダ aファイル
oldフォルダ aファイル
oldフォルダ bファイル

差分があるファイルは差分のあるセルの背景を水色にしています。

ちなみに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をループさせています。

指定されたファイルやシートが存在しない場合は、以下の処理をスキップし、次のループに入ります。

ファイル名をワイルドカードで指定し、ヒットするファイルが同一フォルダが複数存在する場合、一番最初にヒットしたファイル同士のみが比較差分されるため注意が必要です。また、シート名をワイルドカードで指定することはできません。

コメント

タイトルとURLをコピーしました