特定の文字を別シートに抜き出す

Sub ExtractRowsBasedOnText()
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim SpecificText As String

    ' ソースとターゲットのワークシートを設定
    Set SourceSheet = ThisWorkbook.Worksheets("data")
    Set TargetSheet = ThisWorkbook.Worksheets.Add
    TargetSheet.Name = "抽出データ"

    ' 特定の文字を設定
    SpecificText = "ca"

    ' ソースシートの最後の行を取得
    LastRow = SourceSheet.Cells(SourceSheet.Rows.Count, "B").End(xlUp).Row

    ' ターゲットシートのヘッダーをコピー
    SourceSheet.Rows(1).Copy Destination:=TargetSheet.Rows(1)

    ' ソースシートをループして特定の文字を含む行を抽出
    For i = 2 To LastRow
        If InStr(1, SourceSheet.Cells(i, "B").Value, SpecificText) > 0 Then
            SourceSheet.Rows(i).Copy Destination:=TargetSheet.Rows(TargetSheet.Cells(TargetSheet.Rows.Count, "B").End(xlUp).Row + 1)
        End If
    Next i

    MsgBox "抽出が完了しました。", vbInformation, "完了"
End Sub