Hm...

hab einmal was von mir ausgedünnt und mit den Zeiten gespielt

bei ca. 50 Treffer fällt Öffnen der einzelnen Excel-Dateien viel stärker ins Gewicht, als...

exzessives Einschränken der Ordner wo.....

Wenn du Lust, dann teste mal selbst und versuche dann  Const m_Turbo zu vertauschen,

wird aber sein, dass du dein Excel "aufrüsten" musst!

Gruß

aufran

Option Explicit
' ***********************************************************************************
' ***** ACHTUNG - Microsoft Scripting Runtime in VBA-Editor-Verweise anhaken *******
' ***********************************************************************************
'
'ab hier
Const m_Path As String = "V:\0101"                                   'Startup
'
'Liste der Ordner wo
Const m_IncludeFolder As String = "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 oQueue 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 DoIt()
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 oQueue = CreateObject("System.Collections.Queue")
   If Len(m_IncludeFolder) > 0 Then
      ArrLimited = Split(m_IncludeFolder, ",")
      IsLimited = True
   End If
   Call FolderTest
   If oQueue.Count > 0 Then Call FilesTest
   If oQueue.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 oQueue = 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 oQueue.Count > 0
      blnHit = False
      strPath = oQueue.Dequeue
      '
      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 oQueue.Count > 0
      blnHit = False
      strPath = oQueue.Dequeue
      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 oQueue.Count > 0
      strPath = oQueue.Dequeue
      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
            End If
         End If
      Next fl
   Loop
'
   oQueue.Clear
   For lngCnt = 0 To objSortedList.Count - 1
      oQueue.Enqueue 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
      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
      oQueue.Enqueue 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