Excelのあれこれ ~ シート比較マクロ

前置き

2つのシートを比較するマクロを書いてみました。バグってたらすみません。

※本記事のマクロは、Excel2010で動作確認しました。

作戦

  • 任意の2シートを比較
  • 比較対象は、セルの内容と、セルの塗りつぶし色
  • 結果は、新規ブックに出力する
  • セルの結合を解除して比較する
  • 比較するファイルは編集しない
  • 常にセルA1から比較するのではなく、比較開始セルを指定できる

シート選択フォーム

シート選択フォーム

ブックとシートを選択し、基準セル(比較開始セル)を指定するフォームを作り、DiffFormと名付けました。DiffForm.frmDiffForm.frxです。

ついでに、比較処理のコードも、このフォームのコードとして書きます。

[2013-11-10]バグ発覚です。ブックを選び直したときに、シートのコンボボックスをクリアしてないので、シートコンボが太り続けますね。

比較処理

比較処理(DiffForm.frm)
'比較する。
Private Sub diffThem(leftSheet As Worksheet, leftOffset As String, rightSheet As Worksheet, rightOffset As String)
  '新規ブック作成。
  Dim wb As Workbook
  Set wb = Workbooks.Add
  
  '3つのシートを準備。
  Dim diff As Worksheet
  Dim left As Worksheet
  Dim right As Worksheet
  Set diff = remainOneSheet(wb, "diff")
  Set left = duplicateSheet(wb, leftSheet, "left")
  Set right = duplicateSheet(wb, rightSheet, "right")
  diff.Activate

  '比較範囲を決める。
  Dim leftOffsetCol As Integer
  Dim leftOffsetRow As Integer
  Dim rightOffsetCol As Integer
  Dim rightOffsetRow As Integer
  leftOffsetCol = left.Range(leftOffset).Column
  leftOffsetRow = left.Range(leftOffset).Row
  rightOffsetCol = right.Range(rightOffset).Column
  rightOffsetRow = right.Range(rightOffset).Row
  Dim w As Integer
  w = uMax(uRightEdge(left) - leftOffsetCol + 1, uRightEdge(right) - rightOffsetCol + 1)
  Dim h As Integer
  h = uMax(uBottomEdge(left) - leftOffsetRow + 1, uBottomEdge(right) - rightOffsetRow + 1)

  '比較する。
  Dim c As Integer
  Dim r As Integer
  Dim count As Integer
  count = 0
  For r = 0 To h - 1
    For c = 0 To w - 1
      Dim leftCell As Range
      Dim rightCell As Range
      Set leftCell = left.Cells(leftOffsetRow + r, leftOffsetCol + c)
      Set rightCell = right.Cells(rightOffsetRow + r, rightOffsetCol + c)
      If leftCell.Value <> rightCell.Value Then     '値が違う?
        diff.Cells(r + 1, c + 1).Value = leftCell.Value & vbCrLf & "↓" & vbCrLf & rightCell.Value
        markCell diff.Cells(r + 1, c + 1)
        markCell leftCell
        markCell rightCell
        count = count + 1
      End If
      If leftCell.Interior.color <> rightCell.Interior.color Then   '塗りつぶし色が違う?
        checkCell diff.Cells(r + 1, c + 1)
        checkCell leftCell
        checkCell rightCell
        count = count + 1
      End If
    Next c
  Next r

  '結果報告。
  If count > 0 Then
    diff.Cells.ColumnWidth = 2
    diff.Activate
    ActiveWindow.zoom = 50
    MsgBox "のべ" & count & "件の相違が見つかりました。"
  Else
    MsgBox "違いは見つかりませんでした。"
    wb.Close False
  End If
End Sub

まず、新規ブックを作り、3つのシートを準備します。比較結果を載せるシートが1つ(diff)と、比較対象のコピーを載せるシートが2つ(leftとright)です。コピーを作るとき、ついでにセルの結合を解除しておきます。remainOneSheet()とduplicateSheet()はPrivate関数です。コードは添付ファイルDiffForm.frmを参照して下さい。

次に比較範囲を決めます。基準セルと、各シートの右下隅のセルから、範囲の大きい方を取ります。uXxxYyy()といった名前の関数は汎用関数です(コードは後述)。

あとは1セルずつ比較しながら、差異を見つけたら、diffシートに差異内容を出力したり、left/rightシートの該当セルに印をつけていきます。markCell()やcheckCell()もPrivate関数です。

差異の数もカウントしておき、最後にメッセージボックスで報告します。

使用例

こんな感じで呼び出します。

'シート比較。
Sub diffSheets()
  Load DiffForm
  DiffForm.Show
End Sub

結果は、こんな感じです。

比較結果

汎用関数(utils.bas)

罫線描画
'罫線を描く。
Public Sub uDrawLine(r As Range, edge As Variant, Optional colorIndex As Integer = xlColorIndexAutomatic, Optional thick As Boolean = False)
  With r.Borders(edge)
    .LineStyle = xlContinuous
    If thick Then
      .Weight = xlMedium
      .colorIndex = colorIndex
    End If
  End With
End Sub
min
'小さい方。
Public Function uMin(a As Integer, b As Integer) As Integer
  uMin = b
  If a < b Then
    uMin = a
  End If
End Function
max
'大きい方。
Public Function uMax(a As Integer, b As Integer) As Integer
  uMax = b
  If a > b Then
    uMax = a
  End If
End Function
使用セルの右辺
'何列目まで使っているか。
Public Function uRightEdge(sh As Worksheet) As Integer
  uRightEdge = sh.Range("A1").SpecialCells(xlCellTypeLastCell).Column
End Function
使用セルの底辺
'何行目まで使っているか。
Public Function uBottomEdge(sh As Worksheet) As Integer
  uBottomEdge = sh.Range("A1").SpecialCells(xlCellTypeLastCell).Row
End Function
Last modified:2013/11/10 10:32:43
Keyword(s):
References:[Windowsリテラシ]
This page is frozen.