こんばんは

今のコードは，1つのみの単語で検索抽出ですが
2つ以上でもできますか？

今まで   新幹線
例   新幹線，飛行機，電車


 ，カンマを入れて「新幹線，飛行機，電車」
 ３つの単語がある条件で抽出する




Sub ()
    Dim myStr As String
    Dim WS As Worksheet
    Dim buf As Worksheet
    Dim i As Long
    Dim myF As Range
    Dim myAdd As String
    
    myStr = InputBox("検索する文字列を入力して下さい")
    If myStr = "" Then Exit Sub
    On Error Resume Next
    Set WS = Worksheets("出力シート")
    On Error GoTo 0
    If WS Is Nothing Then
        Set WS = Worksheets.Add(Before:=Worksheets(1))
        WS.Name = "出力シート"
    Else
        WS.UsedRange.ClearContents
    End If
    For Each buf In Worksheets
        If buf.Name <> WS.Name Then
            Set myF = buf.UsedRange.Find(myStr)
            If Not myF Is Nothing Then
                myAdd = myF.Address
                Do
                    i = i + 1
                    myF.EntireRow.Copy WS.Cells(i, 1)
                    WS.Cells(i, 1).NumberFormatLocal = "[$-411]ggge""年""m""月""d""日"";@"
                    WS.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, myF.Row)     '追加
                    Set myF = buf.UsedRange.FindNext(myF)
                Loop While myAdd <> myF.Address
                Set myF = Nothing
            End If
        End If
    Next
    If i = 0 Then MsgBox myStr & " は見つかりませんでした"
    Set WS = Nothing
End Sub

１行ずつ評価、転記を繰り返す例

    Dim s
    Dim r As Range
    
    s = Split(myStr, "，")
    
    For Each buf In Worksheets
        If buf.Name <> WS.Name Then
            For Each r In buf.UsedRange.Rows
                If Application.Min(Application.CountIf(r, s)) > 0 Then
                    i = i + 1
                    r.EntireRow.Copy WS.Cells(i, 1)
                    WS.Cells(i, 3).Resize(, 2).Value = Array(buf.Name, r.Row)
                End If
            Next
        End If
    Next