このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

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

スポンサーリンク

二つのシートのセル範囲データを配列を使って高速で比較します。差分があった場合、セルに色を付けたり、フォントの色を変えたり、データを書き換えたりする操作を解説したいと思います

くるみこ
くるみこ

今回もApplication.InputBox使います。それから、セルに設定を書いておいて、その設定を読み込んで使う方法についてもあわせて解説したいと思います!

セル範囲のデータを変更があった部分だけ書き換えることって意外と多いんですよね。具体的な方法がわかればすごく助かります。

是非よろしくお願いしますm(_ _)m

前回のおさらいはこちらの記事です(^^)/ 下のカードをクリックすれば開きます

くるみこ
くるみこ

前回記事でわかったことは

・配列に一括代入したセル範囲データは範囲を指定して一括代入すれば速い
・セル範囲の値を代入したVariant型配列のインデックスは必ず「1」から始まる
・Applicaton.InputBoxメソッドの Type:=8 でマクロ実行中にセル指定できる
・セル範囲指定も代入(貼付け)先セルの選択も自由に操作できる

【この記事でわかること
・シートのセル範囲データを配列を使って比較する方法
・その比較した差分に対してセルデータを操作する方法
・Application.InputBoxを利用した場合と設定セルを利用する方法を解説

スポンサーリンク

シートのセル範囲データを配列で比較する方法

シートのセル範囲データを利用する方法については、前回記事で紹介しました。二つのセル範囲データを比較検証する方法とその差分についてセルを操作する方法を紹介していきます

処理のロジックをフロー図で検討

・このようなフローになるように考えて書いたコードが次のサンプルです

Application.InputBoxで範囲選択するサンプルコード

'指定セル範囲の差分抽出サンプル
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

以下、コード内にコメントを入れていない部分を解説します

・11~18行目、Application.InputBoxを二つ出します。一つ目が元の表(範囲)二つ目が比べたい表(範囲)を指定させます。別シートや別ブックのシートでもOKです
・21~22行目、それぞれ選択したセルからワークシート名をオブジェクト変数に入れています
・23行目で、シートをアクティブにしています。(アクティブにしないとエラーになる)
・27行目は、選択したセルの個数をカウントして処理を分岐しています
・40~55行目は、元シート(セル範囲)に対して同じように設定しています
・58~59行目で、画面描画と自動再計算を抑止しています
・62~72行目で、「対象シート」を基準に、行・列の2次元ループ処理を行っています
・65行目が、セルを比較している部分です
・66~67行目で、比較結果に差分がある場合に双方のセルの背景色を黄色に変更しています
61行目に「On Error Resume Next」を入れてエラー回避しています

セルの設定を使って差分セルを処理するサンプルコード

・上のコードでは、差分があった場合にセルを「黄色」くする設定にしています
・また、69行目のデータを書き換える部分はコメントアウトしています
・では、これをセルの設定を使って変更できるようにカスタマイズしてみます

セル設定を読み込む関数(Functionステートメント)

'指定セルの書式取得用関数
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

・ここでも Applocation.InputBox を利用することにしました
使いたい設定をあらかじめどこかのセルを使って「見本セル」を設定しておきます
・6行目、Applocation.InputBox で「見本セル」を選択させます
・12行目で、「見本セル」に「書き換える」という文字が書かれているかどうか調べます
「書き換える」となっていた場合、「1」違う場合「0」を変数「a」に代入します
・18行目で、フォントの色を調べて変数「a」に区切り文字「,」を付けて追記します
・20行目は、セル背景色です。調べた結果を同じく変数「a」に「,」を付けて追記します
・22行目で、関数CellsFormatに変数「a」の値を代入しています
・関数CellsFormatの中身は「”1 or 0,フォントの色番号,セル背景色番号”」という文字列になっています

最初のコードをカスタマイズしたコード

'【汎用】指定セル範囲の差分抽出サンプル改
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

【追加・変更した箇所の説明】
・58行目で、新しくVariant型の変数「a」を用意しています
・59行目は、関数「CellsFormat」を呼び出して先ほどの取得した設定文字列を受け取り
Split関数を使って「,」区切りで分割した一次元配列を変数「a」に代入しています
・70~73行の各設定で代入しているのは一次元配列「a」の要素です
75行目で、「a(0)」が「1」(=書き換える)だった場合、差分データを書き換えます

・こんな感じなら簡単なツールとして使えるんじゃないかと思います。いかがですか?
・関数の部分で取得したのは、今回は「フォントの色」と「セル背景色」だけでしたが、「フォントの大きさや太さ」「罫線の各種設定」「セルの書式」「配置」などいろいろ設定しておけばよさそうです。設定しておいて使いたいものだけ使えばいいんですから

スポンサーリンク

まとめ(おわりに)

・いかがでしたでしょうか?
「いつも汎用でだれでも使えて活用できるように考えてvbaを使う」というポリシーを念頭に今回の記事も書いたつもりです
実行例のイメージが掴みづらいので「GIF画像」を二つ配置していますが、
実際にはいろいろな動作が考えられます。是非、実際に動かしてみてください!
サンプルファイルを用意していますのでよろしければお使いください(^^)

まとめと感想など

くるみこ
くるみこ

Application.InputBox ばかり使いましたね。でも、自由度は高いし、小さい設定には使いやすいと思うんですよね。汎用的に使うには便利ですよね(^^)
今回の解説はいかがでしたか?

はい! 解説もかなり理解できるようになってきました!

今回もすごく勉強になりました(^^)

くるみこ
くるみこ

今回紹介したコードは、別ブックのセル範囲も設定でるので単独のツールとしても活用できますね。これもApplication.InputBoxを使ったので簡単に実現できている部分ですね(^^) 次回の解説はまだ検討中です。少し待っていてね!

・シートのセル範囲データを配列を使って比較する方法
・配列で比較した差分に対してセルデータを設定するには位置情報を加味する
・Application.InputBoxを利用した場合と設定セルを利用する方法
・Functionステートメントでセル書式を調べる関数について解説
・関数の戻り値に区切り文字をセットして、Sprit関数で一次元配列にする方法

マクロ(VBA)を実行する際は必ずバックアップを取ってから行ってください
・マクロ(VBA)は実行後にファイルを保存すると元に戻すことはできません!
・実行後にファイルを保存せず終了すれば、実行前に戻すことができます!


ブログランキングに参加しています(^^) 応援よろしくお願いしますm(_ _)m

今後の記事について

今回の記事はいかがだったでしょうか。皆さまのお役に立てたなら幸いです(^^;
「汎用でだれでも使えて活用できるように考えてvbaを使う」というポリシー
当面は「中級者?向けマクロVBA」の記事を継続して書いていきます

【検討中の今後の記事内容は・・・・・】
・実務に役立つものを提供できるよう現在検討中です
・その他雑記的に「小ネタなどいろいろ」・・・・・
・今後の記事にもご期待ください(^^)/

記事のサンプルファイルをダウンロードできます

今回の記事のサンプルをダウンロードできるようにしています
過去の記事で使用したサンプルファイルがダウンロードできるページを設置しています
こちら(このリンク先)からご利用ください

スポンサーリンク

スポンサーリンク