No.1530 条件に一致するファイルの一覧を出力 その３

シートに検索したい語句を入力して、その語句をファイル名に含むファイルの一覧を出力するマクロ

参照でMicrosoft Scripting RuntimeとWindows script host object modelを追加する。
コチラの環境はExcel2010です。

検索語シートに検索したい語を空行なしで入力

検索用の文字列がたしか256文字超えるとエラーになるらしい。チェックしてない。

実行用のシートはこんな感じで（図は実行後）ButtonにpushButtonを登録する。

Option Explicit

Sub setFileList(searchPath)
    Dim startCell As Range
    Dim maxRow As Long
    Dim maxCol As Long

    Set startCell = Cells(5, 2) 'このセルから出力し始める
    startCell.Select
    
    'シートをいったんクリア
    maxRow = startCell.SpecialCells(xlLastCell).Row
    maxCol = startCell.SpecialCells(xlLastCell).Column
    If startCell.Row < maxRow Then
        Range(startCell, Cells(maxRow, maxCol)).ClearContents
    End If
    
    Call getFileListWSH(searchPath)
    startCell.Select
End Sub

Sub getFileListWSH(searchPath)

    Dim FSO As New FileSystemObject
    Dim objFiles As File
    Dim objFolders As Folder
    Dim separateNum As Long

    'サブフォルダ取得
    For Each objFolders In FSO.GetFolder(searchPath).SubFolders
        Call getFileListWSH(objFolders.Path)
    Next
    
    Dim WSH, wExec, sCmd As String, Result As String
    Set WSH = CreateObject("WScript.Shell")         ''(1)
    WSH.CurrentDirectory = searchPath
    Dim myWord, myWords
    For Each myWord In Worksheets("検索語").Range("A:A")
        If myWord = "" Then Exit For
        myWords = myWords & " *" & myWord & "*.*"
    Next
    sCmd = "dir " & myWords & " /A-D/B"                                ''(2)
    Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)    ''(3)
    Do While wExec.Status = 0                       ''(4)
        DoEvents
        Do
           Result = wExec.StdOut.ReadLine                   ''(5)
           If Result = "" Then Exit Do
           ActiveCell.Value = searchPath
           ActiveCell.Offset(0, 1).Value = Result
           ActiveCell.Offset(1, 0).Select
        Loop
    Loop
    Do
       Result = wExec.StdOut.ReadLine                   ''(5)
       If Result = "" Then Exit Do
       ActiveCell.Value = searchPath
       ActiveCell.Offset(0, 1).Value = Result
       ActiveCell.Offset(1, 0).Select
    Loop
    Set wExec = Nothing
    Set WSH = Nothing

    
End Sub
Sub pushButton()
    Dim t1, t2
    t1 = Timer
    Call setFileList(Cells(2, 2))   'フォルダパスを入力するセル
    t2 = Timer
    MsgBox (Format(t2 - t1, "0.0秒かかったよ"))
End Sub