Hallo Andre! Hatte mal getestet und auch mehrer Fehler erzeugt und Dateien, die er icht finden konnte. Bei der Version hier lief es dann eigentlich - die Fehler von vorher kamen nicht mehr bzw. wurden unterdrückt. Liegt glaube ich am Server - auf der "richtigen" Festplatteklappt es ja super. Also probiers mal damit.

Viele Grüße

Dim dateien()
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

Application.ScreenUpdating = False
Application.AskToUpdateLinks = False


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

Call txtsuchen(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
     
    '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
          
Application.ScreenUpdating = True
Application.AskToUpdateLinks = False

End Sub
    
 
  
Function txtsuchen(quelle As String)
Dim suche
Dim ordner()
Dim i As Long

On Error Resume Next

ReDim ordner(0)
ordner(0) = 0
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
'MsgBox 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
        ordner(0) = ordner(0) + 1
        ReDim Preserve ordner(ordner(0))
        ordner(ordner(0)) = suche
    Else
        If Right(suche, 5) = ".xlsx" 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
'jetzt durch die Ordner gehen
For i = 1 To UBound(ordner)
    If Dir(ordner(i), vbNormal) = "" And Left(ordner(i), 1) <> "." Then
        Call txtsuchen(quelle & "\" & ordner(i))
        ChDir (quelle)
    End If
Next
End Function