Chatさん。未検証
再帰使わずキュー処理
Sub FastSearchMinimal()
Dim fso As Object, q As Collection, f As Object, i As Object
Dim r As Long: r = 2
Dim k As String: k = "sample"
Set fso = CreateObject("Scripting.FileSystemObject")
Set q = New Collection: q.Add fso.GetFolder("C:\TestFolder")
With Sheets(1): .Cells.Clear: .Range("A1:C1").Value = Array("種類", "名前", "パス"): End With

Do While q.Count > 0
Set f = q(1): q.Remove 1
For Each i In f.SubFolders: q.Add i: If InStr(1, i.Name, k, vbTextCompare) > 0 Then WriteRow r, "フォルダ", i.Name, i.Path
Next
For Each i In f.Files: If InStr(1, i.Name, k, vbTextCompare) > 0 Then WriteRow r, "ファイル", i.Name, i.Path
Next
Loop
MsgBox "完了"
End Sub

Sub WriteRow(ByRef r As Long, t As String, n As String, p As String)
With Sheets(1): .Cells(r, 1).Resize(1, 3).Value = Array(t, n, p): End With: r = r + 1
End Sub