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

参照で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