Hallo!
Also bin grad nicht sicher, woran es liegen kann. Würde noch ein wenig testen.
Außer du hast keine Lust mehr dazu, dann springen wir gleich zur evtl. Abschlußlösung. Dafür wäre interessant, ob die Ordnerstruktur immer die gleiche ist oder ob da auch Ordner hinzukommen bzw. die relevanten Dateien verschoben werden. Die Pfade zu den Ordner in den Code schreiben wäre dann umständlich. Würde da eher voschlagen, dass in einem Blatt (bspw. Blatt 2 ) in Spalte A nacheinander die Pfade zu den Ordnern geschrieben werden - einmalige Fleißarbeit. Der Code würde dann die Pfade aus den Zeilen nehmen und durchgehen und schauen.
Alternativ tausche mal die Funktion am Codeende hiergegen. Gehe dann mal den Pfad immer um eins Hoch und teste. Der zeigt dir dann alle Obekte - Dateien und Ordner - an dem Pfad an (hoffe mal es sind nicht zuviele). Beginnen tut er mit . dann .. und dann der Rest. Dateien haben eine Endung, Ordner nicht. Da wäre die Frage, ob er die Ordner erkennt - also anzeigt. Wenn das nicht klappt, wissen wir zumindest wieso er nix findet. Findet er die Ordner, liegt es dann wohl am Folgecode (ggf. der Attributprüfung). Falls deine Ordner zu groß sind, vllt. irgendwo auf dem Server einen "Testumgebung" mit ein paar Ordnern und zwei Dateien je Ordner anlegen.
Alternativ hätte ich dann noch eine Variante, mit der ich anders auf die Ordner zugreife (nicht mit DIR() ). Würde die dann noch versuchen. Da würde ich das Dateiattribut nicht auslesen (vllt. liegt da der Fehler dran, dass er den Ordner nicht als Ordner erkennen möchte).
Da ich grad daheim bin, kann ich nicht selber auf einem Server testen - würde frühestens morgen gehen. Viele Grüße
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 = ""
msgbox 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
|