Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1820to1824
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 Unterordner einbeziehen

VBA Unterordner einbeziehen
19.03.2021 14:07:18
MarC
Hallo,
ich habe ein Makro erstellt das mir alle xlsx Dateien die sich in dem ausgewählten Ordner befinden nach einem bestimmten Kriterium abgearbeitet werden. Jetzt möchte ich aber nicht nur die Dateien des ausgewählten Ordners bearbeiten lassen sondern auch alle Unterordner. Würde mir hier jemand bitte helfen?
Könnte man auch mehrere Excel Formate abfragen? Aktuell werden nur Dateien mit dem xlsx Format bearbeitet.
Beispieldatei:
https://www.herber.de/bbs/user/144959.xlsm

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Unterordner einbeziehen
19.03.2021 21:31:17
MarC
Hi Jochen, den Beitrag habe ich noch nicht gesehen danke =)

AW: VBA Unterordner einbeziehen
19.03.2021 14:28:28
Nepumuk
Hallo MarC,
teste mal:
Option Explicit

Public Sub Auslesen()
    Dim strDateiname As String
    Dim strVerzeichnis As String
    Dim i As Long
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objWorkbook As Workbook
    
    strVerzeichnis = GetFolder & "\"
    
    If strVerzeichnis <> "\" Then
        
        Application.ScreenUpdating = False
        
        astrFolders = GetFolders(strVerzeichnis)
        
        For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
            
            strDateiname = Dir$(astrFolders(ialngFolders) & "*.xls*")
            
            Do Until strDateiname = vbNullString
                
                Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strDateiname)
                
                With objWorkbook.Worksheets("Tabelle1")
                    
                    For i = 7 To .Cells(.Rows.Count, 3).End(xlUp).Row
                        If Date > DateAdd("m", 6, .Cells(i, 3).Value) Then .Cells(i, 2).ClearContents
                    Next i
                    
                    objWorkbook.Close SaveChanges:=True
                    
                    Set objWorkbook = Nothing
                    
                End With
                
                strDateiname = Dir$
                
            Loop
        Next
        Application.ScreenUpdating = True
        MsgBox "Inhalte wurden gelöscht!"
    End If
End Sub

Private Function GetFolder() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .InitialFileName = "D:\Test\"
        .ButtonName = "Öffnen"
        .Title = "Ordnerauswahl"
        If .Show Then GetFolder = .SelectedItems(1)
    End With
End Function

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
ein Problem
19.03.2021 23:59:26
MarC
Danke für deine Hilfe Nepumuk. Der Code läuft gut durch. Eine Sache ist mir beim ausführen aufgefallen bzw passiert und zwar wenn eine Excel Datei im Ordner ist die nicht das gesuchte Tabellenblatt enthält schmiert der Code ab. Mit einer If Abfrage davor und Exit kann ich den Fehler abfangen aber es werden dann keine weiteren Dateien bearbeitet.
Wie kann ich denn Dateien ignorieren die nicht das Tabellenblatt enthalten?

AW: ein Problem
20.03.2021 07:25:45
Nepumuk
Hallo MarC,
so:
Public Sub Auslesen()
    Dim strDateiname As String
    Dim strVerzeichnis As String
    Dim i As Long
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objWorkbook As Workbook
    Dim objWorksheet As Worksheet
    
    strVerzeichnis = GetFolder & "\"
    
    If strVerzeichnis <> "\" Then
        
        Application.ScreenUpdating = False
        
        astrFolders = GetFolders(strVerzeichnis)
        
        For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
            
            strDateiname = Dir$(astrFolders(ialngFolders) & "*.xls*")
            
            Do Until strDateiname = vbNullString
                
                Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strDateiname)
                
                For Each objWorksheet In objWorkbook.Worksheets
                    
                    If objWorksheet.Name = "Tabelle1" Then Exit For
                    
                Next
                
                If Not objWorksheet Is Nothing Then
                    
                    With objWorksheet
                        
                        For i = 7 To .Cells(.Rows.Count, 3).End(xlUp).Row
                            If Date > DateAdd("m", 6, .Cells(i, 3).Value) Then .Cells(i, 2).ClearContents
                        Next i
                        
                        objWorkbook.Close SaveChanges:=True
                        
                        Set objWorkbook = Nothing
                        
                    End With
                    
                    Set objWorksheet = Nothing
                    
                End If
                
                strDateiname = Dir$
                
            Loop
        Next
        Application.ScreenUpdating = True
        MsgBox "Inhalte wurden gelöscht!"
    End If
End Sub

Gruß
Nepumuk

Anzeige
AW: ein Problem
20.03.2021 07:27:56
Nepumuk
Oops,
da fehlt noch das Schließen der Mappe:
Public Sub Auslesen()
    Dim strDateiname As String
    Dim strVerzeichnis As String
    Dim i As Long
    Dim astrFolders() As String
    Dim ialngFolders As Long
    Dim objWorkbook As Workbook
    Dim objWorksheet As Worksheet
    
    strVerzeichnis = GetFolder & "\"
    
    If strVerzeichnis <> "\" Then
        
        Application.ScreenUpdating = False
        
        astrFolders = GetFolders(strVerzeichnis)
        
        For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
            
            strDateiname = Dir$(astrFolders(ialngFolders) & "*.xls*")
            
            Do Until strDateiname = vbNullString
                
                Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strDateiname)
                
                For Each objWorksheet In objWorkbook.Worksheets
                    
                    If objWorksheet.Name = "Tabelle1" Then Exit For
                    
                Next
                
                If Not objWorksheet Is Nothing Then
                    
                    With objWorksheet
                        
                        For i = 7 To .Cells(.Rows.Count, 3).End(xlUp).Row
                            If Date > DateAdd("m", 6, .Cells(i, 3).Value) Then .Cells(i, 2).ClearContents
                        Next i
                        
                        objWorkbook.Close SaveChanges:=True
                        
                        Set objWorkbook = Nothing
                        
                    End With
                    
                    Set objWorksheet = Nothing
                    
                Else
                    
                    objWorkbook.Close SaveChanges:=False
                    
                End If
                
                strDateiname = Dir$
                
            Loop
        Next
        Application.ScreenUpdating = True
        MsgBox "Inhalte wurden gelöscht!"
    End If
End Sub

Gruß
Nepumuk

Anzeige
AW: ein Problem
20.03.2021 14:11:51
MarC
Danke danke Nepumuk es funktioniert. Jetzt habe ich noch eine Frage. Und zwar möchte ich mit einer ProgressBar zeigen dass das Makro läuft. Meine ProgressBar funktioniert aber das Problem ist das die immer wieder geöffnet und geschlossen wird, weil meine Abhängige Variable i sich in einem Bereich befindet die immer wieder gestartet und geschlossen wird wenn das jeweilige Dokument fertig ist.

For i = 7 To .Cells(.Rows.Count, 3).End(xlUp).Row
If Date > DateAdd("m", 6, .Cells(i, 3).Value) Then .Cells(i, 2).ClearContents
Next i
Wenn ich jetzt die Abfrage Call ProgressBar ganz an den Anfang von Code setze wird das UserForm zwar aufgerufen aber nicht gezählt weil sich i ja wo anders befindet. Kann man anstatt irgendeinen RowCount auch eine Zeit nehmen, damit der Balken sich bewegt?
Gruß Marc
Call ProgressBar(i/ .Cells(.Rows.Count, 63).End(xlUp).Row)


Anzeige
AW: ein Problem
20.03.2021 15:42:54
Oberschlumpf
Zitat: Jetzt habe ich noch eine Frage
Hi MarC,
Gegenfrage: Wieso erstellst du dann nicht einen neuen Beitrag?!
Deine "noch eine Frage" hat so gar nix mit dem Ursprungsproblem dieses Beitrags von dir zu tun.
Natürlich kann Nepu... weiterhin antworten, wenn er will, aber ich frag mich trotzdem, wieso manch ein Fragender nich selbst auf die Idee kommt: neue Frage = neuer Beitrag
Ciao
Thorsten

AW: ein Problem
20.03.2021 15:47:32
Nepumuk
Hallo Marc,
benutze UBound(astrFolders) als Progressbar-Max und ialngFolders als Zähler.
Was besseres fällt mir dazu nicht ein.
Gruß
Nepumuk

Anzeige
AW: ein Problem
20.03.2021 18:49:50
MarC
Nochmals Danke Nepumuk. So habe ich es auch gemacht, wenn aber zu wenig Files im Ordner sind ändert sich der Status nur langsam und zu grob. Ich habe es jetzt so gelassen wie es war also bei dem Punk
For i = 7 to.............
Das hat vorher schon funktioniert mich hat nur gestört das jede Mappe am Ende des Prozesses angezeigt wurde obwohl Screenupdating false ist. Das habe ich jetzt mit dem Befehl am Anfang und Ende so gut es geht ausgeblendet.
Windows(strFileName).Visible = False
Grüße
MarC
Anzeige

183 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige