Anzeige
Archiv - Navigation
1796to1800
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Ordner per Schleife öffnen

VBA Ordner per Schleife öffnen
09.12.2020 10:57:53
Excel
Hallo zusammen,
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.
Ich wollte dies mit einer Schleife lösen, kann aber nur einen expliziten Ordner mit der Eingabe von dessen Pfad öffnen. Gibt es eine Möglichkeit (gerne mit Code) jeden einzelnen Ordner durchzugehen und die Struktur entsprechend anzupassen? Auf ein händisches copy & paste würde ich gerne verzichten. Vielen Dank im Voraus für Eure Hilfe.

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Ordner per Schleife öffnen
09.12.2020 11:30:00
Nepumuk
Hallo,
teste mal:
Beachte, wenn dein Desktop auf OneDrive liegt funktioniert das nicht.
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) & "*.pdf")
        
        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

Gruß
Nepumuk
Anzeige
AW: VBA Ordner per Schleife öffnen
10.12.2020 10:33:10
Excel
Hallo Nepumuk,
vielen Dank! Das klappt super!
Wie muss man den Code ändern damit auch Ordner in denen keine PDF liegt gelöscht werden?
Gruß
Excel Noob
AW: VBA Ordner per Schleife öffnen
10.12.2020 10:39:11
Nepumuk
Hallo,
so:
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") & "\OneDrive\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) & "*.pdf")
        
        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
    
    For ialngFolders = LBound(astrFolders) + 1 To UBound(astrFolders)
        
        If Dir$(astrFolders(ialngFolders) & "*.pdf") = vbNullString Then _
            Call RmDir(Path:=astrFolders(ialngFolders))
        
    Next
End Sub

Gruß
Nepumuk
Anzeige

245 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige