Hallo! Also aufgeben wäre jetzt keine Lösung. :-) Ist halt nur blöd, dass ich nicht am Server testen kann. Also die Ausgabe ist faszinierend. Auf nem "normalen" Rechner geht es auch mit leeren Ordnern, habe es grad mal nachgestellt. Mhm.

Also warum 2 so ist, wie es ist, weiß ich nicht. Eigentlich unlogisch. Das heißt ja, dass er nicht mal in die Funktion kommt, sondern den Pfad ncht erkennt. Hat der Pfad (bzw. der letzte Ordnername) irgendwelche Leerzeichen oder Sonderzeichen? Vllt. müssen wir da mal schauen.

Ich habe unten mal eine Version die nicht auf DiR aufbaut. Probiere die mal. Ich glaube aber mittlerweile nicht, dass es klappt. :-D

Da er immer nur eine bestimmte Weite geht, bin ich grad am Überlegen, ob er evtl. im Speicher nicht genügend Platz hat und dann einen Teil einfach verfallen lässt. Den findet man dann ggf. auch nicht mehr.

Kann ich im Worksheet 1 der aufrufenden Datei in die Spalten B und C Daten"zwischenspeichern" oder hast du da was stehen? Würde dann mal eine Variante basteln, die nicht die Daten in einem array im Speicher sammelt, sondern die Ordner und Dateien (also die Pfade) im Blatt ablegt und dann darauf zugreift. Dauert dann nen bissl länger aber dein Probel, ist glaube ich nicht so zeitkritisch .

Gruß

Also hier mal die Version ohne DIR

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
Dim oOrdner
Dim oDateien
Dim datsystem
Dim knoten
Dim datei
Dim ablage

Set datsystem = CreateObject("Scripting.FileSystemObject")
quelle = ordner(ordner(0) + 1)

ordner(0) = ordner(0) + 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
        If Left(ablage.Name, 1) <> "." Then
            
            ReDim Preserve ordner(UBound(ordner) + 1)
            ordner(UBound(ordner)) = ablage.Path
      
        End If
Next ablage

For Each datei In oDateien
        If Left(datei.Name, 1) <> "." Then
            
            If Right(datei.Name, 4) = ".xls" Then    'ggf. noch an xlsx anpassen etc. aber auch die Zahl dazu
                If (Len(datei.Name) <> Len(Replace(datei.Name, "_Planung", "")) Or Len(datei.Name) <> Len(Replace(datei.Name, "_planung", "")) Or Len(datei.Name) <> Len(Replace(datei.Name, "_PLANUNG", ""))) And Len(datei.Name) <> Len(Replace(datei.Name, "2016", "")) Then
                dateien(0) = dateien(0) + 1
                ReDim Preserve dateien(dateien(0))
                dateien(dateien(0)) = datei.Path
                End If
            End If
        End If
Next datei

Set datsystem = Nothing
Set knoten = Nothing
Set oDateien = Nothing
Set oOrdner = Nothing

End Function