Guten Abend,

NUN - nicht ganz so. Ablaufschema in meinen Codes kurz gefasst:

Ab Startpunkt (Const m_Path) nach unten und jede Abzweigung bis zum Ende.

1) Hier nur eine Liste der Ordner die den (Const m_IncludeFolder) genügen.

Nach dieser Liste in den aufgeführten Ordnern die Datei-Typprüfung und

wenn Typ =  OK, dann Vergleich mit der Dateinamenvorgabe (Const m_IncludeFiles)

Vergleich erfolgreich, dann nur diesen Pfad die schon leere Liste zurück.

2) Die Liste erneut abarbeiten, dort stehen nun ja nur die Workbook-FullName der Gesuchten.

Und erst jetzt erfolgt gezielt der Dateizugriff (Open bzw. OLEDB)

3) Der Rest ist ja bekannt

Casus Cnaxus ist Pkt. 1) - wie viele "dumme" Unterordner liegen unter dem Startpunkt,

denn womöglich steht dort ein Ordner "Woswasi"  und enthält die gesuchten Unterordner!

Ergo kommt das FSO ins Schwitzen, wenn sich ein paar Hundert Ordner unter der Startwurzel

eingereiht haben. Die Zeit kann nicht beeinflusst werden - das FSO Objekt ist immer unsortiert!

Die Bremse Workbook.Open hatten wir ja schon und ohne diese Methode benötigt der Rest

d.h. Pkt2) u. Pkt 3) nur wenige Einhundertstel Sekunden.

EGAL, dein Wunsch ist der Vater des Gedankens und überhaupt nicht schwer:

Aus dem QUEUE mach ich STACK und schon wird so aufgelegt, dass das unterste Verzeichnis

in jedem Ast zu Oberst liegt. Dann nehme ich eben nur 1 Blatt vom Stapel und verwerfe den Rest.

Option Explicit
' ***********************************************************************************
' ***** ACHTUNG - Microsoft Scripting Runtime in VBA-Editor-Verweise anhaken *******
' ***********************************************************************************
'
'ab hier
Const m_Path As String = "V:\0101\SCHULEN"                                   'Startup
'
'Liste der Ordner wo
Const m_IncludeFolder As String = "SCHULEN,Rahmenvertrag, Abrechnung"
'Const m_IncludeFolder As String = ""                                'all Folders
'
'Liste der Dateien wo, gesucht wird immer UCASE()
Const m_IncludeFiles As String = "_Planung, Testfile"                'File includes
'
'Voreinstellung was
Const m_DATA As Variant = "aktuell"                                  'search DATA
'
' ----------------------------------------------------------------------------------
'NUR EXCEL Dateien
Const m_FileType As String = "Microsoft Excel"                        'only
' ----------------------------------------------------------------------------------
'
'Auswahl wie abgefragt wird
' ***********************************************************************************
' ***** ACHTUNG - TURBO = "Microsoft.ACE.OLEDB.12.0"
' ***********************************************************************************
Const m_Turbo As Boolean = True
'Const m_Turbo As Boolean = False ' = Workbook.Open
'
' ***********************************************************************************
' ***** ACHTUNG - keine Fehlersteuerung - d.h. sinnlose Konstanten vermeiden!  *****
' ***********************************************************************************
'
'
'
Dim objFso As Object                                              'FileSystemObject
Dim oStack As Object                                              'Stack
Dim objSortedList As Object                                       'Sorted List
Dim IsLimited As Boolean                                          'Folders restricted
Dim ArrLimited() As String                                        'Array restricted
Dim strDATA As String
'
Sub DoItStackLast()
If Len(m_IncludeFiles) = 0 Then Exit Sub                          'useless
If m_FileType <> "Microsoft Excel" Then Exit Sub                  'useless
'
strDATA = InputBox("gesuchter Wert = ", , m_DATA)
If strDATA = "" Then Exit Sub                                     'useless
'
Set oStack = CreateObject("System.Collections.Stack")
   If Len(m_IncludeFolder) > 0 Then
      ArrLimited = Split(m_IncludeFolder, ",")
      IsLimited = True
   End If
   Call FolderTest
   Debug.Print Join(oStack.toarray, Chr(10))
   If oStack.Count > 0 Then Call FilesTest
   Debug.Print Join(oStack.toarray, Chr(10))
   If oStack.Count > 0 Then
      If m_Turbo = True Then                                      'OLEDB catch
         Call HitOLEDB
      Else                                                        'OPEN File
         Call HitOpen
      End If
   End If
   '
   Call MsgBox("Fertig", vbExclamation, "")
   '
Set oStack = Nothing
End Sub
'
Private Sub HitOLEDB()
Dim strPath As String
Dim blnHit As Boolean, lngCnt As Long
'
Application.ScreenUpdating = False
   Sheets(1).Columns(1).ClearHyperlinks
   Sheets(1).Columns(1).ClearContents
   Do While oStack.Count > 0
      blnHit = False
      strPath = oStack.Pop
      Debug.Print "Hit ", strPath
      '
      blnHit = FindItOnce(strPath, strDATA)
      '
      If blnHit = True Then
         lngCnt = lngCnt + 1
         Cells(lngCnt, 1).Hyperlinks.Add anchor:=Cells(lngCnt, 1), Address:=strPath
      End If
   Loop
Application.ScreenUpdating = True
End Sub
'
Private Sub HitOpen()
Dim strPath As String
Dim oWs As Excel.Worksheet, Rng As Excel.Range, hRng As Excel.Range
Dim blnHit As Boolean, lngCnt As Long
'
Application.ScreenUpdating = False
   Sheets(1).Columns(1).ClearHyperlinks
   Sheets(1).Columns(1).ClearContents
   Do While oStack.Count > 0
      blnHit = False
      strPath = oStack.Pop
      Debug.Print "Hit ", strPath
      Workbooks.Open (strPath)
         For Each oWs In Workbooks(2).Sheets
            Set Rng = oWs.UsedRange
             Set hRng = Rng.Find(strDATA)
             If Not hRng Is Nothing Then blnHit = True
         Next oWs
      Workbooks(2).Close False
      If blnHit = True Then
         lngCnt = lngCnt + 1
         Cells(lngCnt, 1).Hyperlinks.Add anchor:=Cells(lngCnt, 1), Address:=strPath
      End If
   Loop
Application.ScreenUpdating = True
End Sub
'
Private Sub FilesTest()
Dim fldStart As Object                                            'Folder
Dim fld As Object                                                 'Folder
Dim fl As Object                                                  'File
Dim strPath As String, strFull As String, lngCnt As Long
'
Set objFso = CreateObject("scripting.FileSystemObject")
Set objSortedList = CreateObject("System.Collections.Sortedlist")
'
   Do While oStack.Count > 0
      strPath = oStack.Pop
      Set fldStart = objFso.getfolder(strPath)
      Set fld = fldStart.Files
      For Each fl In fld '.Files
         If InStr(fl.Name, Chr(126)) = 0 Then                     'temp. files
         'Debug.Print fl.Name, fl.Type
            If InStr(fl.Type, m_FileType) > 0 Then
               strFull = fl
               '***************************************************************
               If HitFile(fl.Name) = True Then
                  objSortedList.Add strFull, 0                    'first hit
                  Exit For
               '***************************************************************
               End If
            End If
         End If
      Next fl
   Loop
'
   oStack.Clear
   For lngCnt = 0 To objSortedList.Count - 1
      oStack.Push objSortedList.GetKey(lngCnt)
   Next lngCnt
'
'
Set objFso = Nothing
Set fld = Nothing
Set fl = Nothing
Set objSortedList = Nothing
End Sub
'
Private Sub FolderTest()
Dim fldStart As Object                                            'Folder
Dim fld As Object                                                 'Folder
Dim str As String, lngCnt As Long
'
Set objFso = CreateObject("scripting.FileSystemObject")
Set fldStart = objFso.getfolder(m_Path)
Set objSortedList = CreateObject("System.Collections.Sortedlist")
'
   For Each fld In fldStart.subFolders
      str = fld
      Debug.Print str
      If IsLimited Then
         If HitLimit(str) Then _
            objSortedList.Add str, 0
      Else
            objSortedList.Add str, 0
      End If
      Call sbFolderTest(fld)
   Next fld
'
   For lngCnt = 0 To objSortedList.Count - 1
      oStack.Push objSortedList.GetKey(lngCnt)
   Next lngCnt
'
Set objFso = Nothing
Set fldStart = Nothing
Set objSortedList = Nothing
End Sub
'
Private Function sbFolderTest(sFolder As Object)
Dim sbfld As Object
Dim sbStr As String
   For Each sbfld In sFolder.subFolders
      sbStr = sbfld
      If IsLimited Then
         If HitLimit(sbStr) Then _
         objSortedList.Add sbStr, 0
      Else
         objSortedList.Add sbStr, 0
      End If
      Call sbFolderTest(sbfld)
   Next sbfld
End Function
'
Private Function HitLimit(ByVal strHit As String) As Boolean
Dim varE As Variant
   For Each varE In ArrLimited
      If InStr(strHit, Trim(varE)) > 0 Then HitLimit = True
   Next varE
End Function
'
Function HitFile(ByVal strHit As String) As Boolean
Dim Arr() As String, ustrHit As String, varE As Variant
   ustrHit = UCase(strHit)
   Arr = Split(m_IncludeFiles, ",")
   For Each varE In Arr
      If InStr(ustrHit, UCase(Trim(varE))) > 0 Then HitFile = True
   Next varE
End Function
'
Private Function FindItOnce(ByVal strFullName As String, Optional ByVal ToDo As Variant) As Boolean
'
'**********************************************************************************
' ACHTUNG TURBO
'**********************************************************************************
' ggf. können Einschränkungen am installierten Office den  OLEDB-Zugriff verhindern
' - hier getestet unter Excel Version 15.0 = Excel 2013
' - Verweise im VBA Editor beachten
' ggf. AccessDatabaseEngine passend zum Windows Betreibmichsystem
' http://www.microsoft.com/de-de/download/details.aspx?id=13255
'**********************************************************************************
'
Const SEL_FROM As String = "SELECT * FROM "
'
Dim oConn As Object
Dim oTblRs As Object, oRs As Object, oFld As Object
Dim sSQL As String
Dim strFnd As String
Dim oList As Object                                               'ArrayList
'
On Error GoTo nix
         Set oList = CreateObject("System.Collections.ArrayList")
'
         Set oConn = CreateObject("ADODB.Connection")
         Set oTblRs = CreateObject("ADODB.Recordset")
         With oConn
            .Provider = "Microsoft.ACE.OLEDB.12.0"
            .ConnectionString = "Data Source=" & strFullName & ";" & _
            "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""
            .Open
         End With
         'tables
         Set oTblRs = oConn.OpenSchema(20)
         '
         If Not oTblRs.EOF Then
            sSQL = SEL_FROM & Chr(91) & oTblRs.Fields(2).Value & Chr(93)
            Set oRs = CreateObject("ADODB.Recordset")
            oRs.Open sSQL, oConn, 3, 1, 1
            If Not oRs.EOF Then
               For Each oFld In oRs.Fields
                  oRs.MoveFirst
                  strFnd = oFld.Name & " = " & Chr(39) & ToDo & Chr(39)
                  oRs.Find strFnd
                  If oRs.EOF = False Then oList.Add strFullName
               Next oFld
               
            End If
         End If
         '
         If oList.Count > 0 Then FindItOnce = True
'
nix:
Set oConn = Nothing
Set oTblRs = Nothing
Set oList = Nothing
End Function