【マクロ・VBA】縦（行）ループして複数ワードで一致させる

Sub 複数ワードでマッチング()

Dim objDIC As Object
Set objDIC = CreateObject("Scripting.Dictionary")
Dim myKey As Variant
Dim i As Long

'アクティブシートのデータをA列（ID）をキーにして「objDIC」に格納

With ThisWorkbook.ActiveSheet
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        objDIC(.Cells(i, 1).Value) = _
            .Cells(i, "B").Value & "," & .Cells(i, "E").Value & "," & .Cells(i, "T").Value
    Next i
End With

'アクティブシートの隣のシートのデータでA列（ID）が「objDIC」に登録されていれば更新
'登録されていなければ「objDIC」に追加

With ThisWorkbook.ActiveSheet.Next
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
        objDIC(.Cells(i, 1).Value) = _
            .Cells(i, "C").Value & "," & .Cells(i, "E").Value & "," & .Cells(i, "G").Value
    Next i
End With

'「objDIC」からkeyを、配列変数（一次）に取り出す
myKey = objDIC.Keys

'新規シートを作成して出力
Worksheets.Add(After:=ActiveSheet).Name = ActiveSheet.Name & "_" & VBA.Format(Now(), "h時mm分ss秒")

With ThisWorkbook.ActiveSheet
    For i = 1 To objDIC.Count
        .Cells(i + 1, "A").Value = myKey(i - 1)
        .Range(.Cells(i + 1, "B"), .Cells(i + 1, "D")).Value = _
            Split(objDIC(myKey(i - 1)), ",")
    Next i
End With

MsgBox "完了"
End Sub