Veja se ajuda:

Sub BuscarArquivos()

pasta = "C:Funcionários"

arq = InputBox("Digitar palavra chave")
ext = InputBox("Digitar extensão do arquivo")

lin = 1

Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(pasta)
Set fc = f.Files
For Each f1 In fc
On Error Resume Next
If Application.WorksheetFunction.Search(arq, f1, 1) > 0 And Right(f1, 3) = ext Then
x = Err.Number
If Err.Number = 0 Then
Cells(lin, 1) = Mid(f1, Len(pasta) + 1, 50)
lin = lin + 1
Err.Number = 0
End If
End If
Next

End Sub