【エクセル・マクロ・VBA】右のシートに無いデータチェック_ディクショナリ

アクティブシートと右隣りのシートの差異をディクショナリで調べる

このVBAコードは、エクセルのアクティブなシートとその右にあるシートを比較して、右側のシートに存在しない行があるかどうかをチェックするためのものです。

＜操作概要＞

アクティブシートとアクティブシートの右隣りのシートに差異を調べたいデータを準備
アクティブシートの右隣りのシートの最終列に１を代入
⇒一列目をキーに最終列をアイテムに代入
アクティブシートのキーに設定している１列目とアクティブシートの右隣りのシートのキーをディクショナリでマッチングして、マッチしなかったデータをアクティブシートの最終列に「-1」を代入

Sub 右のシートに無いデータチェック_ディクショナリ() 

Dim sheet_1 As Worksheet, sheet_2 As Worksheet
Set sheet_1 = ActiveSheet
Set sheet_2 = ActiveSheet.Next

Dim LastLow1 As Long, LastLow2 As Long, LastCol1 As Long, LastCol2 As Long
LastLow1 = sheet_1.Cells(Rows.Count, 1).End(xlUp).Row
LastCol1 = sheet_1.Cells(2, Columns.Count).End(xlToLeft).Column    
LastLow2 = sheet_2.Cells(Rows.Count, 1).End(xlUp).Row
LastCol2 = sheet_2.Cells(2, Columns.Count).End(xlToLeft).Column     

Dim myDic As Object, myKey
Dim c, myVal
Dim i As Long
Set myDic = CreateObject("Scripting.Dictionary")


'相手のシート（ｱｸﾃｨﾌﾞｼｰﾄの右隣り）
On Error Resume Next
For i = 2 To LastLow2
    sheet_2.Cells(i, LastCol2 + 1).Value = 1
         
    If Not myDic.Exists(sheet_2.Cells(i, 1).Value) Then                                           
       myDic.Add (sheet_2.Cells(i, 1).Value), (sheet_2.Cells(i, LastCol2 + 1).Value)        
    End If
Next i

'基のシート（ｱｸﾃｨﾌﾞｼｰﾄ）の最終列の後ろに転記
For i = 2 To LastLow1
        
    If Not myDic.Exists(sheet_1.Cells(i, 1).Value) Then
       sheet_1.Cells(i, LastCol1 + 1).Value = Not myDic.Item(sheet_2.Cells(i, LastCol2 + 1).Value) 
    End If

Next i
    
On Error GoTo 0

Cells.AutoFilter Field:=1

Set myDic = Nothing
Set sheet_1 = Nothing
Set sheet_2 = Nothing

ActiveSheet.Cells(1, LastCol1).Select

MsgBox "完了"
End Sub

解説

まず、2つのシートを変数 sheet_1 と sheet_2 にセットします。そして、それぞれのシートの最終行と最終列を LastLow1、LastCol1、LastLow2、LastCol2 という変数にセットします。

次に、空のディクショナリー myDic を作成し、右側のシートのデータを読み込みながら、各行の最後の列に「1」を設定します。その後、各行の1列目の値を myDic に追加します。もし、1列目の値が既に myDic に存在している場合は、追加せず、その行の最後の列に「1」をセットします。

その後、左側のシートの各行の1列目の値を myDic でチェックし、存在しない場合は、その行の最後の列に「True」を設定します。ここで、右側のシートの最後の列に設定された「1」を使って、左側のシートで新しく設定する列のデータを作成します。

最後に、 myDic をクリアし、自動フィルターを適用して、最後の列を選択し、完了メッセージを表示します。

このコードの速度を向上させるために、 ActiveSheet や ActiveSheet.Next の代わりに、明示的にシート名を指定することができます。また、シートの最終行と最終列をセットする際に、UsedRange を使って実行することができます。最後に、ディクショナリーの要素を追加する前に、If ステートメントを使って存在チェックを行うことができます。これにより、重複を防止し、処理速度が向上します。

上記コードのスピードアップ改善コード

Sub 右のシートに無いデータチェック_ディクショナリ2() 

Dim sheet_1 As Worksheet, sheet_2 As Worksheet
Set sheet_1 = ThisWorkbook.Worksheets("シート1")
Set sheet_2 = ThisWorkbook.Worksheets("シート2")

Dim LastLow1 As Long, LastLow2 As Long, LastCol1 As Long, LastCol2 As Long
LastLow1 = sheet_1.Cells(sheet_1.Rows.Count, 1).End(xlUp).Row
LastCol1 = sheet_1.Cells(2, sheet_1.Columns.Count).End(xlToLeft).Column
LastLow2 = sheet_2.Cells(sheet_2.Rows.Count, 1).End(xlUp).Row
LastCol2 = sheet_2.Cells(2, sheet_2.Columns.Count).End(xlToLeft).Column

Dim myDic As Object, myKey
Dim c, myVal
Dim i As Long
Set myDic = CreateObject("Scripting.Dictionary")

'相手のシート（ｱｸﾃｨﾌﾞｼｰﾄの右隣り）
On Error Resume Next
For i = 2 To LastLow2
    sheet_2.Cells(i, LastCol2 + 1).Value = 1
     
    If Not myDic.Exists(sheet_2.Cells(i, 1).Value) Then
        myDic.Add sheet_2.Cells(i, 1).Value, sheet_2.Cells(i, LastCol2 + 1).Value
    End If
Next i

'基のシート（ｱｸﾃｨﾌﾞｼｰﾄ）の最終列の後ろに転記
For i = 2 To LastLow1
    
    If Not myDic.Exists(sheet_1.Cells(i, 1).Value) Then
        sheet_1.Cells(i, LastCol1 + 1).Value = Not myDic.Item(sheet_1.Cells(i, LastCol1).Value)
    End If
    
Next i

On Error GoTo 0

sheet_1.Cells.AutoFilter Field:=1

Set myDic = Nothing
Set sheet_1 = Nothing
Set sheet_2 = Nothing

ThisWorkbook.Worksheets("シート1").Cells(1, LastCol1).Select

MsgBox "完了"
End Sub

変更点は次のとおりです。

シートの明示的な指定

ActiveSheet や ActiveSheet.Next ではなく、ThisWorkbook.Worksheets(“シート名”) を使用して、シートの明示的な指定を行いました。

要素の存在チェックの追加

ディクショナリーに要素を追加する前に、If ステートメントを使用して、myDic.Exists() メソッドを呼び出して、要素が存在しないかどうかをチェックするようにしました。

コードの修正

次のコードを修正しました。

myDic.Add (sheet_2.Cells(i, 1).Value), (sheet_2.Cells(i, LastCol2 + 1).Value) を myDic.Add sheet_2.Cells(i, 1).Value, sheet_2.Cells(i, LastCol2 + 1).Valueに変更

アクティブシートと右隣りのシートの差異をディクショナリで調べる

＊右隣りのシートにあり、アクティブシートにないデータをメッセージボックス
　に表示／出力シートに表示

Sub シート間_ディクショナリ()

Dim vList As Object
Dim vName As String
Dim i As Long
    
'チェック用のリストを作成する
Set vList = CreateObject("Scripting.Dictionary")
    
    '「突合」ワークシートに対して処理を行う
    With ActiveSheet
        On Error Resume Next
        
        For i = 2 To .Range("A1").CurrentRegion.Rows.Count
            DoEvents
            vList.Add .Cells(i, 1).Value, .Cells(i, 3).Value
        Next
        
        On Error GoTo 0
    End With
    
    
    '「相手」ワークシートに対して処理を行う
    With ActiveSheet.Next
        
        On Error Resume Next
        
        For i = 2 To .Range("A1").CurrentRegion.Rows.Count
            DoEvents
            
            If Not vList.Exists(.Cells(i, 1).Value) Then
                
                vName = vName & .Cells(i, 1).Value & vbCrLf
                
            End If
        Next

        ThisWorkbook.Worksheets("出力").Cells(1, 1).Value = vName  'スピリットでセルに代入
        
        On Error GoTo 0
    End With
    
MsgBox vName
End Sub