Excel VBA シートのセル範囲を配列で比較して差分を抽出

'指定セル範囲の差分抽出サンプル
Sub DifferenceCheckSample()
    Dim rn1 As Range, rn2 As Range
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim oldList As Variant
    Dim newList As Variant
    Dim i As Long, j As Long
    Dim sr1 As Long, sc1 As Long, er1 As Long, ec1 As Long
    Dim sr2 As Long, sc2 As Long, er2 As Long, ec2 As Long
 
    On Error Resume Next
    Set rn1 = Application.InputBox( _
                Prompt:="対象元範囲（表）の先頭セルを選択してください！" _
                & vbCrLf & "または、対象セル範囲を選択指定してください！" _
                , Title:="比較元セル範囲選択", Type:=8)
    Set rn2 = Application.InputBox( _
                Prompt:="比較対象（表）範囲の先頭セルを選択してください！" _
                & vbCrLf & "または、対象セル範囲を選択指定してください！" _
                , Title:="比較対象セル範囲選択", Type:=8)
    On Error GoTo 0
    If rn1 Is Nothing Or rn2 Is Nothing Then Exit Sub
    Set sh1 = rn1.Worksheet
    Set sh2 = rn2.Worksheet
    sh2.Activate    '対象シートを調べる
    sr2 = rn2.Row       '開始行取得
    sc2 = rn2.Column    '開始列取得
    '取得セル範囲を2次元配列に一括代入する
    If rn2.Count = 1 Then
        'セル選択が1個の場合
        '対象シートの最終行列取得
        er2 = sr2 + sh2.Cells(sr2, sc2).CurrentRegion.Rows.Count - 1
        ec2 = sc2 + sh2.Cells(sr2, sc2).CurrentRegion.Columns.Count - 1
        'セル範囲データを配列に入れる
        newList = sh2.Range(Cells(sr2, sc2), Cells(er2, ec2)).Value
    Else
        'セルを複数（範囲で）選択している場合
        newList = rn2.Value
    End If
    Set rn2 = Nothing
    
    sh1.Activate    '元シートの設定を調べる
    sr1 = rn1.Row       '開始行取得
    sc1 = rn1.Column    '開始列取得
    '取得セル範囲を2次元配列に一括代入する
    If rn1.Count = 1 Then
        'セル選択が1個の場合
        '元シートの最終行列取得
        er1 = sr1 + sh1.Cells(sr1, sc1).CurrentRegion.Rows.Count - 1
        ec1 = sc1 + sh1.Cells(sr1, sc1).CurrentRegion.Columns.Count - 1
        'セル範囲データを配列に入れる
        oldList = sh1.Range(Cells(sr1, sc1), Cells(er1, ec1)).Value
    Else
        'セルを複数（範囲で）選択している場合
        oldList = rn1.Value
    End If
    Set rn1 = Nothing
    
    'oldListをnewListに（色つける）(書き換える)処理はここから
    Application.ScreenUpdating = False              '画面描画を停止
    Application.Calculation = xlCalculationManual   '計算を手動に
    '対象シートを基準でループ
    On Error Resume Next    'エラー発生時（データが無い）止めない
    For i = 1 To UBound(newList, 1)
        For j = 1 To UBound(newList, 2)
        '2つのシートの値が異なる場合、セルに色をつける
            If oldList(i, j) <> newList(i, j) Then
                sh1.Cells(i + sr1 - 1, j + sc1 - 1).Interior.Color = 65535
                sh2.Cells(i + sr2 - 1, j + sc2 - 1).Interior.Color = 65535
                'データを書き換える場合はコメントを外す
                'sh1.Cells(i + sr1 - 1, j + sc1 - 1).Value = newList(i, j)
            End If
        Next j
    Next i
    On Error GoTo 0
    Set sh1 = Nothing
    Set sh2 = Nothing
    Application.Calculation = xlCalculationAutomatic '計算を自動に
    Application.ScreenUpdating = True               '画面描画を開始

End Sub

'指定セルの書式取得用関数
Function CellsFormat() As String
    Dim rn As Range
    Dim a As String
 
    On Error Resume Next
    Set rn = Application.InputBox( _
                Prompt:="差分が見つかった場合に書式を設定した" _
                & vbCrLf & "見本となるセルを選択してください！" _
                , Title:="差分セル表示設定", Type:=8)
    On Error GoTo 0
    If rn Is Nothing Then Exit Function
    If rn.Value = "書き換える" Then
        a = "1"
    Else
        a = "0"
    End If
    'フォントの色
    a = a & "," & rn.Cells(1, 1).Font.Color
    'セル背景色
    a = a & "," & rn.Cells(1, 1).Interior.Color

    CellsFormat = a

End Function

'【汎用】指定セル範囲の差分抽出サンプル改
Sub DifferenceCheckSample02()
    Dim rn1 As Range, rn2 As Range
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim oldList As Variant
    Dim newList As Variant
    Dim i As Long, j As Long
    Dim sr1 As Long, sc1 As Long, er1 As Long, ec1 As Long
    Dim sr2 As Long, sc2 As Long, er2 As Long, ec2 As Long
 
    On Error Resume Next
    Set rn1 = Application.InputBox( _
                Prompt:="対象元範囲（表）の先頭セルを選択してください！" _
                & vbCrLf & "または、対象セル範囲を選択指定してください！" _
                , Title:="比較元セル範囲選択", Type:=8)
    Set rn2 = Application.InputBox( _
                Prompt:="比較対象（表）範囲の先頭セルを選択してください！" _
                & vbCrLf & "または、対象セル範囲を選択指定してください！" _
                , Title:="比較対象セル範囲選択", Type:=8)
    On Error GoTo 0
    If rn1 Is Nothing Or rn2 Is Nothing Then Exit Sub
    Set sh1 = rn1.Worksheet
    Set sh2 = rn2.Worksheet
    sh2.Activate    '対象シートを調べる
    sr2 = rn2.Row       '開始行取得
    sc2 = rn2.Column    '開始列取得
    '取得セル範囲を2次元配列に一括代入する
    If rn2.Count = 1 Then
        'セル選択が1個の場合
        '対象シートの最終行列取得
        er2 = sr2 + sh2.Cells(sr2, sc2).CurrentRegion.Rows.Count - 1
        ec2 = sc2 + sh2.Cells(sr2, sc2).CurrentRegion.Columns.Count - 1
        'セル範囲データを配列に入れる
        newList = sh2.Range(Cells(sr2, sc2), Cells(er2, ec2)).Value
    Else
        'セルを複数（範囲で）選択している場合
        newList = rn2.Value
    End If
    Set rn2 = Nothing
    
    sh1.Activate    '元シートの設定を調べる
    sr1 = rn1.Row       '開始行取得
    sc1 = rn1.Column    '開始列取得
    '取得セル範囲を2次元配列に一括代入する
    If rn1.Count = 1 Then
        'セル選択が1個の場合
        '元シートの最終行列取得
        er1 = sr1 + sh1.Cells(sr1, sc1).CurrentRegion.Rows.Count - 1
        ec1 = sc1 + sh1.Cells(sr1, sc1).CurrentRegion.Columns.Count - 1
        'セル範囲データを配列に入れる
        oldList = sh1.Range(Cells(sr1, sc1), Cells(er1, ec1)).Value
    Else
        'セルを複数（範囲で）選択している場合
        oldList = rn1.Value
    End If
    Set rn1 = Nothing
    
    '差分があった場合のセル配色などを設定
    Dim a As Variant
    a = Split(CellsFormat, ",")
        
    'oldListをnewListに（色つける）(書き換える)処理はここから
    Application.ScreenUpdating = False              '画面描画を停止
    Application.Calculation = xlCalculationManual   '計算を手動に
    '対象シートを基準でループ
    On Error Resume Next    'エラー発生時（データが無い）止めない
    For i = 1 To UBound(newList, 1)
        For j = 1 To UBound(newList, 2)
        '2つのシートの値が異なる場合、セルに色をつける
            If oldList(i, j) <> newList(i, j) Then
                sh1.Cells(i + sr1 - 1, j + sc1 - 1).Font.Color = a(1)
                sh1.Cells(i + sr1 - 1, j + sc1 - 1).Interior.Color = a(2)
                sh2.Cells(i + sr2 - 1, j + sc2 - 1).Font.Color = a(1)
                sh2.Cells(i + sr2 - 1, j + sc2 - 1).Interior.Color = a(2)
                'データを書き換える(指定されていたら）
                If a(0) = "1" Then _
                sh1.Cells(i + sr1 - 1, j + sc1 - 1).Value = newList(i, j)
            End If
        Next j
    Next i
    On Error GoTo 0
    Set sh1 = Nothing
    Set sh2 = Nothing
    Application.Calculation = xlCalculationAutomatic '計算を自動に
    Application.ScreenUpdating = True               '画面描画を開始

End Sub