【エクセル・マクロ・VBA】マッチング／全項目／Dictionary／基シート転記

Dictionary：シート間のデータをマッチングして基のデータ（左側のシート）の最終列の隣に結果を代入

＜操作説明＞

調べる基となるデータを左側のシートに準備（＝基データシート）
調べる対象のデータのある相手シートを基データシートの右隣りのシートに設置
基データシートを選択してアクティブ状態にする
相手シートの全データをディクショナリに代入
基データの最終列の右隣りの列に相手シートの全データを記入

Sub 突合_行_ディクショナリ()
    Dim c As Range
    Dim v() As Variant
    Dim cols As Long
    Dim j As Long
    Dim dic As Object
    Dim k As Long
    Dim baseV() As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    
    'アクティブシートの右隣のアイテム取得
    With ActiveSheet.Next

        cols = .UsedRange.Cells(.UsedRange.Cells.Count).Column
    
        For Each c In .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            dic(c.Value) = c.EntireRow.Resize(, cols).Value
        Next
        
    End With
    
    ReDim baseV(1 To 1, 1 To cols)
    
    'アクティブシートに最終列のあとに転記
    With ActiveSheet
        
        With .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
            ReDim v(1 To .Rows.Count)
            
            For Each c In .Cells
                k = k + 1
                If dic.Exists(c.Value) Then
                    v(k) = dic(c.Value)
                Else
                    v(k) = baseV
                End If
            Next
            
        End With
        
        Dim LastCol1
        LastCol1 = .Cells(1, Columns.Count).End(xlToLeft).Address
       .Range(LastCol1).Offset(0, 1).Resize(UBound(v), cols).Value = _
       WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
       .Select
       
   End With
    
MsgBox "完了"
End Sub

解説

アクティブシートの右隣りのシート
A1から最終のセルまでループして一行分を辞書に登録
空白行スケルトン：ReDim baseV(1 To 1, 1 To cols)
アクティブシートのA列の最終行までループ
アクティブシートの右隣りのシートで辞書に登録したデータがアクティブシートのＣにあればＶに代入
アクティブシートの最終列＋１に辞書の内容を転記

Dictionary：シート間のデータをマッチングして基のデータ（左側のシート）の指定列に結果を記入

＜操作説明＞

調べる基となるデータを左側のシートに準備（＝基データシート）
調べる対象のデータのある相手シートを基データシートの右隣りのシートに設置
基データシートを選択してアクティブ状態にする
相手シートA列をキーにA列からBB列をアイテムに代入
基データのA列をキーにしてJ列からBG列にマッチしたものを転記

Sub シート間マッチング_Dictionary_基シート転記()

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With

'基_アクティブシート
Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
Dim ws1 As Worksheet
    Set ws1 = wb1.ActiveSheet
Dim LastRow1 As Long
    LastRow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastCol1 As Long
    LastCol1 = ws1.Cells(1, Columns.Count).End(xlToLeft).Column

'相手_アクティブシートの右のシート
Dim wb2 As Workbook
    Set wb2 = ThisWorkbook
Dim ws2 As Worksheet
    Set ws2 = wb2.ActiveSheet.Next
Dim LastRow2 As Long
    LastRow2 = ws2.Cells(Rows.Count, 2).End(xlUp).Row
Dim LastCol2 As Long
    LastCol2 = ws2.Cells(2, Columns.Count).End(xlToLeft).Column
    
'処理(マッチング)
Dim myDic As Object
Dim i As Long
Set myDic = CreateObject("Scripting.Dictionary")

'処理①相手シートのキーとアイテム取得
For i = 2 To LastRow2
  On Error Resume Next
    If Not myDic.Exists(ws2.Cells(i, 1).Value) Then
           myDic.Add (ws2.Cells(i, 1).Value), (ws2.Range("A" & i & ":BB" & i).Value)
    End If
Next i

'処理②基_アクティブシートに転記
For i = 2 To LastRow1
  On Error Resume Next
    ws1.Range("J" & i & ":BG" & i).Value = myDic.Item(ws1.Cells(i, 1).Value)
Next i


'キーアイテム削除
Set myDic = Nothing
Set wb2 = Nothing
Set ws2 = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With

MsgBox "完了"
End Sub