0
0

More than 1 year has passed since last update.

EXCELブック比較ツール

Last updated at Posted at 2023-06-09

仕様

EXCELブック同士を比較するツールを作成しました。
下準備としてはこのツールが乗るEXCELブックのC2に比較Aファイル、C3に比較Bファイル、C4に比較結果ファイルを指定してください。
フルパスです。
シチュエーションとしては変更を掛けたブックの差分をみたり、環境違いのファイルを比較するのにお使いください。
ブックAをコピーしCとします。AとBのセルを1つずつ比較し、違った場合はCブックの該当セルを黄色くし、コメントに差分内容(B側)を残します。
実ファイルをそのまま参照せず、コピーを取って使用してください。

仕様としては下記になります。
・Aのワークシートの印刷範囲を使い、対象範囲を決定します。この時空白ワークシートの場合はスキップをします。
・結合セルがあっても対応しています。

苦労した点

対象範囲がシートごとに違うのでどうしようかと思いましたが、印刷範囲を利用すれば漏れが減るかと思い、「.PageSetup.PrintArea」を採用しました。
結合セルがあると左上には値が格納されいますが、それ以外は空白扱いなのでエラーを出してしまいます。なのでマージセルであった場合は「CellA.MergeArea(1)」で値を格納しそれを比較してエラーを回避させています。

Sub ComoareAndOutput()
    Dim wbA As Workbook
    Dim wbB As Workbook
    Dim wbC As Workbook
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim wsC As Worksheet
    Dim CellA As Range
    Dim CellB As Range
    Dim CellC As Range
    Dim wbApath As Variant
    Dim wbBpath As Variant
    Dim wbCpath As Variant
    Dim i As Long
    Dim j As Long
    Dim lastRowA As Long
    Dim lastColumnA As Long
    Dim Count_WS As Long
    Dim PrintArea_wsA As Variant
    Application.ScreenUpdating = False
    MsgBox "比較処理を開始します。しばらくお待ちください。"
    ' ブックを開く
    Set wbApath = Range("C2")
    Set wbBpath = Range("C3")
    Set wbCpath = Range("C4")
    
    'ファイルをコピーします。
    Dim objFSO As Object, txtSource As String, txtDestination
    Set objFSO = CreateObject("Scripting.FileSystemObject")
      objFSO.CopyFile wbApath, wbCpath
      
    Set wbA = Workbooks.Open(wbApath)
    Set wbB = Workbooks.Open(wbBpath)
    Set wbC = Workbooks.Open(wbCpath)
        
    For Count_WS = 1 To wbA.Worksheets.Count
    Set wsA = wbA.Worksheets(Count_WS)
    Set wsB = wbB.Worksheets(Count_WS)
    Set wsC = wbC.Worksheets(Count_WS)
    
    With wsA
        '使用しているセル範囲を印刷範囲に設定する。
        .PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(4, 4)).Address
        
        If WorksheetFunction.CountA(.UsedRange) = 0 And Worksheets.Count > 1 Then
        Else
            .PageSetup.PrintArea = .UsedRange.Address
        End If
        
        '印刷範囲を引数に格納する。
        PrintArea_wsA = .PageSetup.PrintArea
    End With
    
    Cell_tmp_A = Split(PrintArea_wsA, "$")
    Cell_tmp_A_ROW = Cell_tmp_A(3)
    Cell_tmp_A_Column = Cell_tmp_A(4)
    
    'アルファベットを数字に変換
    ColNo = Range(Cell_tmp_A_ROW & "1").Column

    lastRowA = ColNo
    lastColumnA = Cell_tmp_A_Column


    ' AをベースにBを比較しCに出力する。
    For i = 1 To lastRowA
        For j = 1 To lastColumnA
                Set CellA = wsA.Cells(i, j)
                Set CellB = wsB.Cells(i, j)
                Set CellC = wsC.Cells(i, j)
                ' 結合セルかどうか確認する。
                If CellA.MergeCells Then
                    '空白かどうか確認する。
                    If Not IsNull(wsA.Cells(i, j).Value) And Len(Trim(wsA.Cells(i, j).Value)) > 0 Then
                        'AブックとBブックを比較し、差分がある場合は黄色セルにし、コメントで差分を残す。
                        If CellA.MergeArea(1) <> CellB.MergeArea(1).Value Then
                                CellC.MergeArea(1).Interior.Color = 65535
                                CellC.MergeArea(1).AddCommentThreaded (CellB.MergeArea(1).Value)
                            Else
                        End If
                    End If
                    
                Else
                    '空白かどうか確認する
                    If Not IsNull(wsA.Cells(i, j).Value) And Len(Trim(wsA.Cells(i, j).Value)) > 0 Then
                        'AブックとBブックを比較し、差分がある場合は黄色セルにし、コメントで差分を残す。
                        If wsA.Cells(i, j).Value <> wsB.Cells(i, j).Value Then
                            wsA.Cells(i, j).Copy
                            wsC.Cells(i, j).PasteSpecial
                            wsC.Cells(i, j).Interior.Color = 65535
                            wsC.Cells(i, j).AddCommentThreaded (wsB.Cells(i, j).Value)
                        Else
                        End If
                    End If
                End If
        Next j
    Next i
 Next Count_WS
    
    ' 結果を保存する。比較元は保存しない。
    wbC.Save
    wbC.Close
    wbB.Close SaveChanges:=False
    wbA.Close SaveChanges:=False
    Application.ScreenUpdating = True
    MsgBox "処理が終了しました。" & wbCpath & "を確認してください"
    
End Sub

以上です。

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0
0