bestimmte Dateien auflisten

Sub SucheDatei()
Dim Fso, Ordner, varDatei, strWert
Dim SucheDatei$, sDateiName$, sTabName$, strDateiSammler$, sPfad$
Dim meCalc As Integer
sPfad = "C:\Dateiordner"    'Pfad anpassen!!!!!!!!!!!!!
SucheDatei = "*.xls"        'Suchfilter!!!!!!!!!!!!!!!!
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Ordner = Fso.getfolder(sPfad)
With Application
meCalc = .Calculation
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
'Schleife über alle Dateien im Ordner
For Each varDatei In Ordner.Files
If varDatei Like SucheDatei Then 'prüfe Dateiname
sDateiName = Right$(varDatei, Len(varDatei) - InStrRev(varDatei, "\")) 'Dateiname
strWert = LeseTabname(CStr(varDatei)) 'Funktion lese Zelle H2
If strWert Like "x" Then strDateiSammler = strDateiSammler & Chr(10) & sDateiName 'prü _
fe ob x
End If
Next varDatei
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = meCalc
End With
MsgBox strDateiSammler, vbInformation
End Sub

Function LeseTabname(strFile As String) As String
Dim objDatei As Workbook
Set objDatei = Workbooks.Open(strFile, False, True)
LeseTabname = objDatei.Sheets(1).Range("H2")
objDatei.Close False
End Function