コピー転記してから色付け

Sub コピー転記してから色付け()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim wsKeywords As Worksheet
    Dim lastRowSource As Long
    Dim lastRowKeywords As Long
    Dim i As Long
    Dim j As Long
    Dim keyword As String
    
    ' Sheet1をソース、Sheet2を転記先、Sheet3をキーワードのシートに設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    Set wsKeywords = ThisWorkbook.Sheets("Sheet3")
    
    ' ソースの最終行を取得
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' キーワードの最終行を取得
    lastRowKeywords = wsKeywords.Cells(wsKeywords.Rows.Count, "A").End(xlUp).Row
    
    ' ソースからデータを転記
    For i = 1 To lastRowSource
        ' A列からD列とF列のデータをE列に転記
        wsDestination.Cells(i, "A").Value = wsSource.Cells(i, "A").Value
        wsDestination.Cells(i, "B").Value = wsSource.Cells(i, "B").Value
        wsDestination.Cells(i, "C").Value = wsSource.Cells(i, "C").Value
        wsDestination.Cells(i, "D").Value = wsSource.Cells(i, "D").Value
        wsDestination.Cells(i, "E").Value = wsSource.Cells(i, "F").Value
        
        ' E列のセルがSheet3のA列に記載されているキーワードを含む場合は黄色にする
        For j = 1 To lastRowKeywords
            keyword = wsKeywords.Cells(j, "A").Value
            If InStr(1, wsDestination.Cells(i, "E").Value, keyword) > 0 Then
                wsDestination.Cells(i, "E").Interior.Color = RGB(255, 255, 0) ' 黄色
                wsDestination.Cells(i, "F").Value = "●"
                Exit For ' 一度でも条件に合致したらループを抜ける
            End If
        Next j
    Next i

End Sub

'//--------------------配列パターン

Sub CopyAndHighlight()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim wsKeywords As Worksheet
    Dim lastRowSource As Long
    Dim lastRowKeywords As Long
    Dim dataRange As Variant
    Dim keywordsRange As Variant
    Dim i As Long
    Dim j As Long
    Dim keyword As String
    
    ' Sheet1をソース、Sheet2を転記先、Sheet3をキーワードのシートに設定
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestination = ThisWorkbook.Sheets("Sheet2")
    Set wsKeywords = ThisWorkbook.Sheets("Sheet3")
    
    ' ソースのデータを配列に読み込む
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    dataRange = wsSource.Range("A1:F" & lastRowSource).Value
    
    ' キーワードのデータを配列に読み込む
    lastRowKeywords = wsKeywords.Cells(wsKeywords.Rows.Count, "A").End(xlUp).Row
    keywordsRange = wsKeywords.Range("A1:A" & lastRowKeywords).Value
    
    ' ソースからデータを転記
    For i = 1 To UBound(dataRange, 1)
        ' A列からD列とF列のデータをE列に転記
        For j = 1 To 4
            wsDestination.Cells(i, j).Value = dataRange(i, j)
        Next j
        wsDestination.Cells(i, 5).Value = dataRange(i, 6)
        
        ' E列のセルがSheet3のA列に記載されているキーワードを含む場合は黄色にする
        For j = 1 To UBound(keywordsRange, 1)
            keyword = keywordsRange(j, 1)
            If InStr(1, dataRange(i, 6), keyword) > 0 Then
                wsDestination.Cells(i, 5).Interior.Color = RGB(255, 255, 0) ' 黄色
                wsDestination.Cells(i, 6).Value = "●"
                Exit For ' 一度でも条件に合致したらループを抜ける
            End If
        Next j
    Next i
End Sub