・表のA列が黄色の列を別シートに貼り付ける。コードをコピー

Sub FindAndAddValues()
    
    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim searchValue As String
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    
    ' シート1とシート2を取得
    Set sht1 = ThisWorkbook.Sheets("Sheet1")
    Set sht2 = ThisWorkbook.Sheets("Sheet2")
    
    ' シート1の最終行を取得
    lastRow = sht1.Cells(sht1.Rows.Count, "F").End(xlUp).Row
    
    ' シート1のF列をループし、値を検索して追加
    For i = 1 To lastRow
        searchValue = sht1.Range("F" & i).Value
        
        ' シート2の範囲を指定
        Set searchRange = sht2.Range("A1:F23")
        
        ' シート2の範囲をループし、値を検索して追加
        For Each cell In searchRange
            If cell.Value = searchValue Then
                ' 該当する行の下に改行して値を追加
                sht2.Cells(cell.Row + 1, cell.Column).Value = sht2.Cells(cell.Row + 1, cell.Column).Value & vbCrLf & sht1.Range("A" & i).Value & " " & sht1.Range("E" & i).Value
            End If
        Next cell
    Next i
    
End Sub