VBA Ordner per Schleife öffnen
17.12.2020 13:07:24
Excel
ich hatte schon einmal einen Beitrag in diesem Forum gepostet und sehr gute Hilfe bekommen (shoutout an NEpumuk an dieser Stelle).
Hier mal meine alte Anfrage:
"Ich habe einen Ordner auf dem Desktop (Projekt). In diesem befinden sich mehrere Unterordner. Diese besitzen widerum jeweils 2 bis 3 weitere Unterordner, in welchen sich widerum PDF Dateien befinden.
Wie schaffe ich es die PDFs zu auszuschneiden und eine Ebene höher einzufügen, sodass letztendlich nur mein Hauptordner (Projekt) auf dem Desktop, dessen verschiedene Unterordner und direkt in diesen die PDFs über bleiben. Die 2 bis 3 Unterordner sollen gelöscht werden."
Nun hat sich geändert, dass es auch andere Dateien als PDFs in den Ordnern gibt (ist schon im Code angepasst). Leider habe ich gibt es ein Problem für den Fall, falls ein Untereinordner im Projektordner keine der 3 Unterordner besitzt bzw. die Dateien direkt in den Projektordner geladen werden und der Unterordner, der eigentlich erhalten werden soll gelöscht werden soll. Macht man das indem man eine Schleife vor der if-Schleife einfügt, in der die strFilename ausgelesen wird? Also dass er vergleicht ob er wenn er eine Ebene höher geht noch im Unterordner ist oder sich schon im Hauptordner befindet und folglich die nächste Iteration durchführt
Vielen Dank für Eure Hilfe. Hier mal der Code. Was müsste ich noch anpassen?
Option Explicit
Public Sub Beispiel()
Dim strFolder As String, astrFolders() As String
Dim astrFolder() As String, strParentFolder As String
Dim strFilename As String
Dim ialngFolders As Long
strFolder = Environ$("USERPROFILE") & "\Desktop\Projekt\"
astrFolders = GetFolders(strFolder)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
astrFolder = Split(astrFolders(ialngFolders), "\")
Redim Preserve astrFolder(UBound(astrFolder) - 2)
strParentFolder = Join(astrFolder, "\") & "\"
strFilename = Dir$(astrFolders(ialngFolders) & "*.*")
If strFilename vbNullString Then
Do Until strFilename = vbNullString
Name astrFolders(ialngFolders) & strFilename As strParentFolder & strFilename
strFilename = Dir$
Loop
Call RmDir(Path:=astrFolders(ialngFolders))
End If
Next
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
Redim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder "." And strFolder ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
Redim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function