Moin! Also ein paar Versuche haben wir noch. :-D

Für deinen Vorschlag, müsste der Anwender aber vorher alle Ordner durchgehen und dem Programm mitteilen, dass er dort suchen soll. Ist bei vielen Ordnern und Dateien, die  zudem verteilt sind, möglich aber langwierig. Der User müsste sich da durch die ganzen Verzeichnisse klicken und da die Auswertung (warum auch immer) fehleranfällig ist, müsste er den direkten Ordner wählen um auf Nummer sicher zu gehen. Ansonsten könnte es ja auch sein, dass er die Unterordner nicht mehr findet.  Wäre machbar, würde ich aber als letzte Option wählen wollen.

Hier mal ein neuer Versuch. Dieses mal werden die Ordner zwischengespeichert und dann extra (einzeln) aufgerufen. Die Funktion ist jetzt nicht mehr rekursiv und damit hoffentlich nicht zu belastend für das System.

Probiere das mal bitte. Am Anfang wieder den Pfad eingeben. Viele Grüße

Dim dateien()
Dim ordner()
Option Explicit
   
Sub DateienLesen()
     
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 test
    
  
Dateialt = ThisWorkbook.Name
zeilealt = 1
 
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 = "" 'Pfad eintragen
If Right(quelle, 1) = "\" Then quelle = Left(quelle, Len(quelle) - 1)

If Dir(quelle & "\") = "" Then
    MsgBox "Der Pfad wurde nicht gefunden!"
    End
End If

ReDim ordner(1)
ordner(0) = 0
ordner(1) = quelle

While UBound(ordner) <> ordner(0)
    Call txtsuchen
Wend

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
     
    'die Mappen aufmachen
    Workbooks.Open DateiName, Password:="ABC"
      
    For Each Blatt In Worksheets
        suche = Application.WorksheetFunction.CountIf(ActiveSheet.UsedRange, suchwert & "*")
         
        If suche > 0 Then gefunden = True
         
    Next Blatt
         
    Workbooks(Dateialt).Activate
    Workbooks(Namekurz).Close savechanges:=False
     
    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 txtsuchen()
Dim suche
Dim i As Long
Dim quelle As String


quelle = ordner(ordner(0) + 1)

ordner(0) = ordner(0) + 1


ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
  
  
  
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
   
Do Until suche = ""
    'Normale Dateien rausfiltern
    If (GetAttr(quelle & "\" & suche) = 16) Then
        'die hier ankommen, sind Ordner, extra speichern
        If Left(suche, 1) <> "." Then 'Dir(suche, vbNormal) = "" And Left(ordner(i), 1) <> "." Then
            
            ReDim Preserve ordner(UBound(ordner) + 1)
            ordner(UBound(ordner)) = quelle & "\" & suche
      
        End If

    Else
        If Right(suche, 4) = ".xls" Then    'ggf. noch an xlsx anpassen etc. aber auch die Zahl dazu
            If (Len(suche) <> Len(Replace(suche, "_Planung", "")) Or Len(suche) <> Len(Replace(suche, "_planung", "")) Or Len(suche) <> Len(Replace(suche, "_PLANUNG", ""))) And Len(suche) <> Len(Replace(suche, "2016", "")) Then
                dateien(0) = dateien(0) + 1
                ReDim Preserve dateien(dateien(0))
                dateien(dateien(0)) = quelle & "\" & suche
            End If
        End If
    End If
           
    suche = Dir()
Loop

End Function