Hallo Andre! Also einen Versuch haben wir noch. :-) Inspiriert von aufran habe ich mal die andere Methode in meinen Code integriert. Ist auchgestestet und läuft. Du müsstest dazu aber vorher im VBE bei den Verweisen was extra anklicken. UNd zwar sollten noch die zwei letzten Werte hinzugefügt werden. Falls das nicht passiert oder fehlschlägt, kommt beim Start die Meldung, dass ein Variable nicht dfiniert wurden. Hier mal das Bild

Wie aufran auch schon im Code hat mindestens das letzte - Microsoft Scrpting Runtime - anklicken (steht alphabetisch unten). Die zwei darüber habe ich auch mal mit genommen und hat zumindest der Codeausführung nicht geschadet.

Wenn du das hast, könntest du (theoretisch :-) ) den folgdenden Code verwenden. Da ist jetzt zumindest das Öffnen schneller. Da Methoden/Befehle auf das Recordset fehlgeschlagen sind (kam immer ein Fehler), Werte ich die nicht mit find aus, sondern gehe sie in einer Schleife durch. Falls es klappt, schau mal bitte ob das noch etwas schneller ist. VG

Dim dateien()

Option Explicit
    
Sub DateienLesen2()
      
Dim DateiName As String
Dim quelle As String
Dim i As Long
Dim j As Long
Dim Dateialt As String
Dim zeilealt As Long
Dim Namekurz As String
Dim Blatt As Object
Dim gefunden As Boolean
Dim suchwert As Variant
Dim suche As Variant
Dim oAdoConnection
Dim sAdoConnectString
Dim oAdoRecordset
Dim oAdoRecordset2
Dim ssql
Dim satz
Dim k

Application.ScreenUpdating = False
   
   
Dateialt = ThisWorkbook.name
zeilealt = 1
ActiveSheet.Columns(1).ClearContents

suchwert = InputBox("Zu suchenden Wert eingeben!", "Suchtexteingabe")
  
If suchwert = "" Then
    MsgBox "Sie haben keinen Wert eingegeben oder Abbrechen angeklickt. Das Program wird beendet.", , "Abbruch Eingaben"
    End
End If
  
ReDim dateien(0)
dateien(0) = 0
        
quelle = "V:\0101\SCHULEN\0-FAHRT"
If Right(quelle, 1) = "\" Then quelle = Left(quelle, Len(quelle) - 1)
 
If Dir(quelle & "\") = "" Then
    MsgBox "Der Pfad wurde nicht gefunden!"
    End
End If
 


    Call txtsuchen2("1" & quelle)

 
If dateien(0) = 0 Then
MsgBox "Keine .txt Dateien gefunden!"
Else
'Daten auslesen
           
    For i = 1 To dateien(0)
    DateiName = dateien(i)
    Namekurz = Right(DateiName, InStr(1, StrReverse(DateiName), "\") - 1)
    gefunden = False
      
'#####################################################################################
    Set oAdoConnection = CreateObject("ADODB.CONNECTION")

    If Val(Application.Version) > 11 Then
    'ab Excel 2007
        sAdoConnectString = "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties='Excel 12.0 Xml;HDR=No';Data Source=" & DateiName
    Else
    'Excl 2003
        sAdoConnectString = "Provider=Microsoft.ACE.OLEDB.12.0; Extended Properties='Excel 8.0;HDR=No';Data Source=" & DateiName
    End If

    oAdoConnection.Open sAdoConnectString
    Set oAdoRecordset = CreateObject("ADODB.RECORDSET")
    Set oAdoRecordset = oAdoConnection.OpenSchema(20)
   
    While Not oAdoRecordset.EOF
            ssql = "SELECT * from " & Chr(91) & oAdoRecordset.Fields(2).Value & Chr(93)
            Set oAdoRecordset2 = CreateObject("ADODB.RECORDSET")
            oAdoRecordset2.Open ssql, oAdoConnection, adOpenKeyset, adLockReadOnly
            If Not oAdoRecordset2.EOF Then
            
                satz = oAdoRecordset2.GetRows
               
                 For Each k In satz
                    If k <> 0 Then If InStr(1, k, suchwert, vbTextCompare) Then gefunden = True
                 Next

            End If
            oAdoRecordset.MoveNext
    Wend

    oAdoRecordset.Close
    oAdoRecordset2.Close
    oAdoConnection.Close
      
    Set oAdoRecordset = Nothing
    Set oAdoRecordset2 = Nothing
    Set oAdoConnection = Nothing
    
    
    If gefunden = True Then
        ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(zeilealt, 1), Address:=DateiName, TextToDisplay:=Namekurz
        zeilealt = zeilealt + 2
    End If
  
    Next i
End If
           
End Sub
     
  
   
Function txtsuchen2(pfads As String)
Dim suche
Dim i As Long
Dim quelle As String
Dim oOrdner
Dim oDateien
Dim datsystem
Dim knoten
Dim datei
Dim ablage
Dim dname As String
Dim onam As String
Dim anfang
 
Set datsystem = CreateObject("Scripting.FileSystemObject")
quelle = pfads
 
anfang = Left(pfads, 1)
quelle = Right(pfads, Len(pfads) - 1)
 
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
Set knoten = datsystem.GetFolder(quelle)
 
Set oDateien = knoten.Files
Set oOrdner = knoten.SubFolders
 
For Each ablage In oOrdner
    onam = ablage.name
        If Left(onam, 1) <> "." Then
            If anfang <> "x" Then
            ' tiefe ab der der filter greift
                If anfang = 2 Then
                    Call txtsuchen2("x" & ablage.Path)
                Else
                    Call txtsuchen2((anfang + 1) & ablage.Path)
                End If
            Else
                If InStr(1, onam, "16", 1) > 0 Or InStr(1, onam, "Region", 1) > 0 Or InStr(1, onam, "Rahmenvertrag", 1) > 0 Or InStr(1, onam, "Abrechnung", 1) > 0 Then
                    If InStr(1, onam, "Änderung", 1) > 0 Or InStr(1, onam, "Fahrpl", 1) > 0 Or InStr(1, onam, "14", 1) > 0 Or InStr(1, onam, "13", 1) > 0 Or InStr(1, onam, "12", 1) > 0 Or InStr(1, onam, "11", 1) > 0 Or InStr(1, onam, "10", 1) > 0 Then
                    ' die Werete gefunden, da nichts machen
                    Else
                       Call txtsuchen2("x" & ablage.Path)
                    End If
                End If
            End If
        End If
Next ablage
 
If oOrdner.Count = 0 Then
For Each datei In oDateien
    dname = datei.name
        If Left(dname, 1) <> "." Then
             
            If Right(dname, 4) = ".xls" Then    'ggf. noch an xlsx anpassen etc. aber auch die Zahl dazu
                If (InStr(1, dname, "_Planung", 1) > 0 Or InStr(1, dname, "_planung", 1) > 0 Or InStr(1, dname, "_PLANUNG", 1) > 0) And InStr(1, dname, "2016", 1) > 0 Then
                dateien(0) = dateien(0) + 1
                ReDim Preserve dateien(dateien(0))
                dateien(dateien(0)) = datei.Path
                End If
            End If
        End If
Next datei
End If

Set datsystem = Nothing
Set knoten = Nothing
Set oDateien = Nothing
Set oOrdner = Nothing
 
Application.ScreenUpdating = True

 
End Function