Sub フォルダ内のファイルのテキスト検索()
    Application.DisplayAlerts = False

    '削除処理
    For Each targetSheet In Worksheets
        If targetSheet.Name <> "実行シート" Then
            targetSheet.Delete
        End If
    Next
    
    Dim runSheet As Worksheet
    Set runSheet = ActiveSheet

    lastRow = ActiveSheet.Cells(1, 2).End(xlDown).Row
    
    lastRowPath = ActiveSheet.Cells(1, 1).End(xlDown).Row


    Dim kensakuWords As Range
    Set kensakuWords = Range("B2:B" & lastRow)
    

    
    Dim kensakuWordsSecound As Range
    Set kensakuWordsSecound = Range("C2:C" & lastRow)



    Dim kensakuPaths As Range
    Set kensakuPaths = Range("A2:A" & lastRowPath)
    
    
    Dim newWorkSheet As Worksheet
    

    
    
    
    Dim x As Integer
    Dim p As Integer
    
    For p = 2 To lastRowPath
        Set newWorkSheet = Worksheets.Add()
        newWorkSheet.Name = p - 1
        
        runSheet.Range("B2:B" & lastRow).Copy
        newWorkSheet.Range("B1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        
        runSheet.Range("C2:C" & lastRow).Copy
        newWorkSheet.Range("B2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        
        
        newWorkSheet.Cells(1, 1).Value = kensakuPaths(p - 1, 1)
        For x = 2 To lastRow
            Call フォルダ内のファイルを選択(kensakuWords, kensakuWordsSecound, newWorkSheet, x, kensakuPaths(p - 1, 1))
        Next x
        newWorkSheet.Columns("A:A").AutoFit
    Next p
    
    
    
    
    Worksheets("実行シート").Activate
    Application.CutCopyMode = False
    MsgBox "終了しました。"
End Sub

Sub フォルダ内のファイルを選択(kensakuWords As Range, kensakuWordsSecound As Range, newWorkSheet As Worksheet, x As Integer, myPath As String)
'MsgBox kensakuWord
    Dim myBook As String
    Dim y As Integer
    y = 1
    'myPath = "C:\エクセルマクロ\ファイルの中の文字を検索\work\"
    myBook = Dir(myPath & "*")
    


    Do Until myBook = ""
        'Workbooks.Open myPath & myBook

        'Worksheets(1).Rows(1).Interior.Color = 5287936    'セル緑色

        'Workbooks(myBook).Close SaveChanges:=True    '保存して閉じる
            'MsgBox myBook
        newWorkSheet.Cells(y + 2, 1).Value = myBook
        Call テキスト読み込み(myPath & myBook, kensakuWords, kensakuWordsSecound, newWorkSheet, x, y)
        myBook = Dir
        y = y + 1
    Loop
End Sub

Sub テキスト読み込み(fileName As String, kensakuWords As Range, kensakuWordsSecound As Range, newWorkSheet As Worksheet, x As Integer, y As Integer)

    Open fileName For Input As #1
        Dim cntArray As Variant
        Dim z As Integer
        Dim r As Long
        Dim kensakuWordCnt As Long
        kensakuWordCnt = 0
        r = 1 '1行目から書き出す
        Do Until EOF(1)
        
            Dim buf As String
            Line Input #1, buf
            
            If InStr(buf, kensakuWords(x - 1, 1).Value) <> 0 Then
                'newWorkSheet.Cells(col, i + 1) = buf
                If InStr(buf, kensakuWordsSecound(x - 1, 1).Value) <> 0 And Not IsNull(kensakuWordsSecound(x - 1, 1).Value) Then
                    kensakuWordCnt = kensakuWordCnt + 1
                End If
            Else
                'newWorkSheet.Cells(col, i + 1) = "含まない"
            End If
          
            
            'Dim aryLine As Variant '文字列格納用配列変数
            'aryLine = Split(buf, vbTab) '読み込んだ行をタブ区切りで配列変数に格納
            
            'Dim i As Long
            'For i = LBound(aryLine) To UBound(aryLine)
                'インデックスが0から始まるので列番号に合わせるため+1
            '    Cells(r, i + 1) = aryLine(i)
            'Next
            
            r = r + 1
        
        Loop
    newWorkSheet.Cells(y + 2, x).Value = kensakuWordCnt
    'MsgBox fileName & " " & kensakuWords(x - 1, 1).Value
    Close #1
    
    'MsgBox "終了しました。"
 
End Sub