ヒットする項目を抽出する

Sub TransferData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、カンマで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & ", " & ws2.Cells(j, 3).Value
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = ws2.Cells(j, 3).Value
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub
Sub TransferData2()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、カンマで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & "; " & ws2.Cells(j, 3).Value & "; " & ws2.Cells(j, 4).Value
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = ws2.Cells(j, 3).Value & "; " & ws2.Cells(j, 4).Value
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub
Sub TransferData3()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    Dim i As Long
    Dim j As Long
    Dim keyA As String
    Dim keyB As String
    Dim matchFound As Boolean
    
    ' Sheet1とSheet2を設定
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    
    ' Sheet1とSheet2の最終行を取得
    lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
    
    ' Sheet1を走査してSheet2と比較
    For i = 2 To lastRow1 ' ヘッダー行をスキップ
        keyA = ws1.Cells(i, 1).Value
        keyB = ws1.Cells(i, 2).Value
        matchFound = False
        
        ' Sheet2の行を走査して一致するデータを探す
        For j = 2 To lastRow2 ' ヘッダー行をスキップ
            If ws2.Cells(j, 1).Value = keyA And ws2.Cells(j, 2).Value = keyB Then
                ' 一致するデータが見つかった場合
                If matchFound Then
                    ' 複数の一致がある場合、セミコロンで区切ってD列に追記
                    ws1.Cells(i, 4).Value = ws1.Cells(i, 4).Value & "; " & Format(ws2.Cells(j, 3).Value, "0%") & "; " & Format(ws2.Cells(j, 4).Value, "0%")
                Else
                    ' 最初の一致の場合は単に値を転記
                    ws1.Cells(i, 4).Value = Format(ws2.Cells(j, 3).Value, "0%") & "; " & Format(ws2.Cells(j, 4).Value, "0%")
                    matchFound = True
                End If
            End If
        Next j
    Next i
End Sub