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

Mit VBA Ordner und Unterordner abfragen

Forumthread: Mit VBA Ordner und Unterordner abfragen

Mit VBA Ordner und Unterordner abfragen
15.02.2019 11:42:23
Roman
Hallo zusammen,
kann mir jemand von euch helfen, den Code so abzuändern, dass der Ordner (in dem sich die Datei befindet) plus die darunterliegenden Unterordner abgefragt werden? Im Moment wird nur der Ordner ausgelesen, in dem sich die Datei befindet. Gerne würde ich diese Funktion (z. B. AllSubfolders) per True oder False aktivieren wollen. Und zusätzlich noch eine Möglichkeit, bestimmte Unterordner durch Angabe verschiedener Pfade abzufragen (Hierfür würde ich die Funktion AllSubfolders auf False setzen).
Hoffe, dass mir jemand weiterhelfen kann. Nach mehreren Versuchen komme ich leider nicht zu diesem Erfolg. 
Sub Daten_aus_Protokollen_kopieren()
ActiveSheet.Range("A4:I1000").ClearContents 'Vorgegebenen Tabelleninhalt vor dem Kopieren   _
_
der Daten löschen
Dim StatusCalc
'Makrobremsen lösen - Am Beginn eines Makros
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Const sXlsPath = "C:\Users\admin\Desktop\Dokumente\" 'Pfad zu bestimmtem Ordner
'oder wenn sich die Dateien im selben Ordner befinden
sXlsPath = ThisWorkbook.Path 'Datei im gleichen Ordner wie Auswertungsdateien
Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As  _
Worksheet
Dim aCells As Variant, iNextLine As Long, i As Integer
Set oWks0 = ThisWorkbook.ActiveSheet
aCells = Split(Zellen, ","):  iNextLine = iStartZeile
Set oFso = CreateObject("Scripting.FilesystemObject")
For Each oFile In oFso.GetFolder(sXlsPath).Files
If LCase(oFso.GetExtensionName(oFile.Name)) = "xlsx" Then 'Hier den Dateityp anpassen
If ThisWorkbook.Path  oFile.Name Then
Set oWkb1 = Workbooks.Open(oFile.Path)
Set oWks1 = oWkb1.Sheets(1)
For i = 0 To UBound(aCells)
oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells( _
_
i))).Value
Next
oWkb1.Close False
iNextLine = iNextLine + 1
End If
End If
Next
Beenden: 'Sprungadresse zum Beenden diese Makros
'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub

Anzeige

21
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
15.02.2019 12:00:26
Nepumuk
Hallo Roman,
versuch es mal so:
Option Explicit

Public Sub Beispiel()
    Const FOLDER_PATH As String = "G:\Eigene Dateien\" 'Anpassen
    Dim astrFolders() As String
    Dim strFile As String
    Dim ialngFolders As Long
    astrFolders = GetFolders(FOLDER_PATH)
    For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
        strFile = Dir$(astrFolders(ialngFolders) & "*.xlsx")
        Do Until strFile = vbNullString
            Debug.Print astrFolders(ialngFolders) & strFile
            strFile = Dir$
        Loop
    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
    strPath = pvstrPath
    Do
        strFolder = Dir$(strPath & "*", vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(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

Die Funktion GetFolders liefert den Root-Folder inklusive aller Unterordner zurück. Dann kannst du das Ganze über For-Next steuern. 0 To 0 ist nur der Root-Folder, LBound(astrFolders) To UBound(astrFolders) ist ohne Abfrage alle Unterordner, mit Abfrage nur ausgewählte Ordner.
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
15.02.2019 15:34:01
Roman
Hallo Nepumuk,
danke erstmal für deine Antwort. Ich habe es mit unzähligen Codes dieser Art aus dem Internet versucht, habe es aber nicht geschafft, es mit meinem Code zusammenzuführen.
Hoffe jemand kann mir behilflich sein.
AW: Mit VBA Ordner und Unterordner abfragen
15.02.2019 15:42:24
Nepumuk
Hallo Roman,
du musst doch nur deinen Code an Stelle von:
Debug.Print astrFolders(ialngFolders) & strFile
einsetzen.
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 10:21:19
Roman
Hallo Nepumuk,
habe den Code versucht so einzusetzen, aber es kommt folgende Fehlermeldung: Index außerhalb des gültigen Bereichs
Habe ich den Code richtig eingesetzt?
Und habe die Zeile sXlsPath = ThisWorkbook.Path 'Datei im gleichen Ordner wie Auswertungsdateien entfernt, da Fehlermeldung kam, dass die Variable nicht definiert ist. Und hier For Each oFile In oFso.GetFolder(sXlsPath).Files habe ich statt sXlsPath strFile eingesetzt.
Option Explicit
Public Sub Beispiel()
Const FOLDER_PATH As String = "G:\Eigene Dateien\" 'Anpassen
Dim astrFolders() As String
Dim strFile As String
Dim ialngFolders As Long
astrFolders = GetFolders(FOLDER_PATH)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFile = Dir$(astrFolders(ialngFolders) & "*.xlsx")
Do Until strFile = vbNullString
ActiveSheet.Range("A4:I1000").ClearContents 'Vorgegebenen Tabelleninhalt vor dem Kopieren  _
der Daten löschen
Dim StatusCalc
'Makrobremsen lösen - Am Beginn eines Makros
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Const sXlsPath = "C:\Users\admin\Desktop\Dokumente\" 'Pfad zu bestimmtem Ordner
'oder wenn sich die Dateien im selben Ordner befinden
Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As _
Worksheet
Dim aCells As Variant, iNextLine As Long, i As Integer
Set oWks0 = ThisWorkbook.ActiveSheet
aCells = Split(Zellen, ","):  iNextLine = iStartZeile
Set oFso = CreateObject("Scripting.FilesystemObject")
For Each oFile In oFso.GetFolder(strFile).Files
If LCase(oFso.GetExtensionName(oFile.Name)) = "xlsx" Then 'Hier den Dateityp anpassen
If ThisWorkbook.Path  oFile.Name Then
Set oWkb1 = Workbooks.Open(oFile.Path)
Set oWks1 = oWkb1.Sheets(1)
For i = 0 To UBound(aCells)
oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells( _
_
_
i))).Value
Next
oWkb1.Close False
iNextLine = iNextLine + 1
End If
End If
Next
Beenden: 'Sprungadresse zum Beenden diese Makros
'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
strFile = Dir$
Loop
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
strPath = pvstrPath
Do
strFolder = Dir$(strPath & "*", vbDirectory)
Do Until strFolder = vbNullString
If strFolder  "." And strFolder  ".." Then
If GetAttr(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

Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 12:00:03
Nepumuk
Hallo Roman,
teste mal:
Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef psa() As Any) As Long

Public Sub Daten_aus_Protokollen_kopieren()
    
    Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
    Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
    Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
    
    Dim oWkb1 As Workbook, oWks1 As Worksheet, oWks0 As Worksheet
    Dim aCells As Variant, iNextLine As Long, i As Long
    Dim StatusCalc As XlCalculation
    Dim avntFolders() As Variant, sXlsPath As String
    Dim strFile As String
    Dim ialngFolders As Long
    
    'Makrobremsen lösen - Am Beginn eines Makros
    With Application
        .EnableEvents = False
        StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen
    Range("A4:I1000").ClearContents
    
    sXlsPath = ThisWorkbook.Path & "\" 'Datei im gleichen Ordner wie Auswertungsdateien
    
    Set oWks0 = ActiveSheet
    
    aCells = Split(Zellen, ",")
    
    iNextLine = iStartZeile
    
    avntFolders = GetFolders(sXlsPath)
    
    For ialngFolders = LBound(avntFolders) To UBound(avntFolders)
        
        strFile = Dir$(avntFolders(ialngFolders) & "*.xlsx")
        
        Do Until strFile = vbNullString
            
            If strFile <> ThisWorkbook.Name Then
                
                Set oWkb1 = Workbooks.Open(avntFolders(ialngFolders) & strFile)
                Set oWks1 = oWkb1.Sheets(1)
                
                For i = 0 To UBound(aCells)
                    oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = _
                        oWks1.Range(aCells(i)).Value
                Next
                
                Call oWkb1.Close(SaveChanges:=False)
                
                iNextLine = iNextLine + 1
                
            End If
            
            strFile = Dir$
            
        Loop
    Next
    
    Set oWks0 = Nothing
    Set oWks1 = Nothing
    Set oWkb1 = Nothing
    
    'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
    With Application
        .EnableEvents = True
        .Calculation = StatusCalc
        .ScreenUpdating = True
    End With
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As Variant()
    Dim avntFolders() As Variant
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    strPath = pvstrPath
    Do
        strFolder = Dir$(strPath & "*", vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(strPath & strFolder) And vbDirectory Then
                    Redim Preserve avntFolders(0 To ialngIndex1)
                    avntFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = avntFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    If SafeArrayGetDim(avntFolders) = 0 Then avntFolders = Array(strPath)
    GetFolders = avntFolders
End Function

Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 13:54:54
Roman
Hallo Nepumuk,
danke vorab für deine Überarbeitung. Ich habe
Private Declare PtrSafe Function SafeArrayGetDim Lib _
"oleaut32.dll" (ByRef psa() As Any) As Long
eingefügt, da die Fehlermeldung ...64bit kam.
Der Code funktioniert bis auf, dass Dateien im selben Ordner wie die Auswertungsdatei, ausgelesen werden. Es werden nur die Unterordner berücksichtigt.
Ist es auch möglich, dass ich die Abfrage der Unterordner aktivieren bzw. deaktivieren kann? Und z. B. auch statt der Abfrage aller Unterordner nur bestimmte vorgeben kann? Z. B.
sXlsPath = "C:\Users\admin\Desktop\Dokumente\"
sXlsPath = "C:\Users\admin\Desktop\Dokumente\2017\"
sXlsPath = "C:\Users\admin\Desktop\Dokumente\2018\"
Danke für deine Bemühungen.
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 15:12:51
Nepumuk
Hallo Roman,
1. Das Problem mit dem obersten Ordner habe ich gelöst.
2. Wenn nur ein bestimmter Unterordner durchsucht werden soll, dann nur diesen Ordner oder auch alle Unterordner dieses Unterordners? Soll dann auch der Ordner in dem sich die Makromappe befindet ausgeschlossen sein?
Am einfachsten baue ich dir dazu einen Dialog zur Ordnerauswahl ein.
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 15:18:48
Roman
Hallo Nepumuk,
1. großartig :)
2. auch alle Unterordner des Unterordners. Der Ordner der Makromappe soll nie ausgeschlossen werden.
Am besten wäre es natürlich, wenn ich die einzelnen Funktionen mit True oder False bestimmen könnte. Wenn das nicht so einfach ist, dann wäre ein Dialog mit Ordnerauswahl natürlich auch gut. Auch hierbei sollte der Hauptordner immer mit abgefragt werden.
Gruß
Roman
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 15:53:04
Nepumuk
Hallo Roman,
so ok?
Option Explicit

Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef psa() As Any) As Long

Public Sub Daten_aus_Protokollen_kopieren()
    
    Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
    Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
    Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
    
    Dim oWkb1 As Workbook, oWks1 As Worksheet, oWks0 As Worksheet
    Dim objFileDialog As FileDialog
    Dim aCells As Variant, iNextLine As Long, i As Long
    Dim StatusCalc As XlCalculation
    Dim avntFolders() As Variant, sXlsPath As String
    Dim strFile As String
    Dim ialngFolders As Long
    
    sXlsPath = ThisWorkbook.Path & "\" 'Datei im gleichen Ordner wie Auswertungsdateien
    
    If MsgBox("Alle Unterordner durchsuchen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
        
        avntFolders = GetFolders(sXlsPath) 'Hauptordner und alle Unterordner
        
        Redim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 1)
        
        avntFolders(UBound(avntFolders)) = sXlsPath
        
        Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
        
    Else
        
        If MsgBox("Nur bestimmten Unterordner durchsuchen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
            
            Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
            
            With objFileDialog
                .InitialFileName = sXlsPath
                .InitialView = msoFileDialogViewSmallIcons
                .Title = "Ordner auswählen"
                If .Show Then
                    
                    avntFolders = GetFolders(.SelectedItems(1) & "\") 'Unterordner und seine Unterordner
                    
                    Redim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 1)
                    
                    avntFolders(UBound(avntFolders)) = sXlsPath
                    
                    Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
                    
                Else
                    Exit Sub
                End If
            End With
            
        Else
            
            avntFolders = Array(sXlsPath) 'Nur Hauptordner ohne Unterordner
            
        End If
    End If
    
    'Makrobremsen lösen - Am Beginn eines Makros
    With Application
        .EnableEvents = False
        StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen
    Range("A4:I1000").ClearContents
    
    Set oWks0 = ActiveSheet
    
    aCells = Split(Zellen, ",")
    
    iNextLine = iStartZeile
    
    For ialngFolders = LBound(avntFolders) To UBound(avntFolders)
        
        strFile = Dir$(avntFolders(ialngFolders) & "*.xlsx")
        
        Do Until strFile = vbNullString
            
            If strFile <> ThisWorkbook.Name Then
                
                Set oWkb1 = Workbooks.Open(avntFolders(ialngFolders) & strFile)
                Set oWks1 = oWkb1.Sheets(1)
                
                For i = 0 To UBound(aCells)
                    oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = _
                        oWks1.Range(aCells(i)).Value
                Next
                
                Call oWkb1.Close(SaveChanges:=False)
                
                iNextLine = iNextLine + 1
                
            End If
            
            strFile = Dir$
            
        Loop
    Next
    
    Set oWks0 = Nothing
    Set oWks1 = Nothing
    Set oWkb1 = Nothing
    
    'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
    With Application
        .EnableEvents = True
        .Calculation = StatusCalc
        .ScreenUpdating = True
    End With
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As Variant()
    Dim avntFolders() As Variant
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    strPath = pvstrPath
    Do
        strFolder = Dir$(strPath & "*", vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(strPath & strFolder) And vbDirectory Then
                    Redim Preserve avntFolders(0 To ialngIndex1)
                    avntFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = avntFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    If SafeArrayGetDim(avntFolders) = 0 Then avntFolders = Array(pvstrPath)
    GetFolders = avntFolders
End Function

Private Sub QuickSort(ByVal pvlngLBound As Long, ByVal pvlngUbound As Long, ByRef prvntArray As Variant)
    Dim lngIndex1 As Long, lngIndex2 As Long
    Dim vntTemp As Variant, vntBuffer As Variant
    lngIndex1 = pvlngLBound
    lngIndex2 = pvlngUbound
    vntBuffer = prvntArray(Fix(pvlngLBound + pvlngUbound) / 2)
    Do
        Do While prvntArray(lngIndex1) < vntBuffer
            lngIndex1 = lngIndex1 + 1
        Loop
        Do While vntBuffer < prvntArray(lngIndex2)
            lngIndex2 = lngIndex2 - 1
        Loop
        If lngIndex1 <= lngIndex2 Then
            vntTemp = prvntArray(lngIndex1)
            prvntArray(lngIndex1) = prvntArray(lngIndex2)
            prvntArray(lngIndex2) = vntTemp
            lngIndex1 = lngIndex1 + 1
            lngIndex2 = lngIndex2 - 1
        End If
    Loop Until lngIndex1 > lngIndex2
    If pvlngLBound < lngIndex2 Then Call QuickSort(pvlngLBound, lngIndex2, prvntArray)
    If lngIndex1 < pvlngUbound Then Call QuickSort(lngIndex1, pvlngUbound, prvntArray)
End Sub

Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 17:09:27
Roman
Hallo Nepumuk,
der Code funktioniert soweit ganz gut und ist gut anpassbar, aber wenn ich Unterordner auswähle und sich noch Unterordner in diesem Ordner befinden, werden nur die Dateien vom Unterordner des Unterordners abgefragt. Und ist es umsetzbar, dass ich mehrere Ordner auswählen kann?
Anbei der aktuelle Code
Public Sub Daten_aus_Protokollen_kopieren_mit_ausgewählten_Unterordnern()
Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
Dim oWkb1 As Workbook, oWks1 As Worksheet, oWks0 As Worksheet
Dim objFileDialog As FileDialog
Dim aCells As Variant, iNextLine As Long, i As Long
Dim StatusCalc As XlCalculation
Dim avntFolders() As Variant, sXlsPath As String
Dim strFile As String
Dim ialngFolders As Long
sXlsPath = ThisWorkbook.Path & "\" 'Datei im gleichen Ordner wie Auswertungsdateien
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.InitialFileName = sXlsPath
.InitialView = msoFileDialogViewSmallIcons
.Title = "Ordner auswählen"
If .Show Then
avntFolders = GetFolders(.SelectedItems(1) & "\") 'Unterordner und seine  _
Unterordner
'Folgende 2 Zeilen mit ' ausklammern, wenn alle ausgewählten Unterordner,  _
aber ohne Hauptordner abgefragt werden sollen
'ReDim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 1)
'avntFolders(UBound(avntFolders)) = sXlsPath
Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
Else
Exit Sub
End If
End With
'Makrobremsen lösen - Am Beginn eines Makros
With Application
.EnableEvents = False
StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen
Range("A4:I1000").ClearContents
Set oWks0 = ActiveSheet
aCells = Split(Zellen, ",")
iNextLine = iStartZeile
For ialngFolders = LBound(avntFolders) To UBound(avntFolders)
strFile = Dir$(avntFolders(ialngFolders) & "*.xlsx")
Do Until strFile = vbNullString
If strFile  ThisWorkbook.Name Then
Set oWkb1 = Workbooks.Open(avntFolders(ialngFolders) & strFile)
Set oWks1 = oWkb1.Sheets(1)
For i = 0 To UBound(aCells)
oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = _
oWks1.Range(aCells(i)).Value
Next
Call oWkb1.Close(SaveChanges:=False)
iNextLine = iNextLine + 1
End If
strFile = Dir$
Loop
Next
Set oWks0 = Nothing
Set oWks1 = Nothing
Set oWkb1 = Nothing
'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
With Application
.EnableEvents = True
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub

Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 17:35:59
Nepumuk
Hallo Roman,
ok, den Fehler habe ich beseitigt. Siehe Code.
Aber ich kenne keinen Ordnerdialog mit dem sich mehrere Ordner auswählen lassen. Da müsste man was eigenes Schreiben. Willst du nur die Unterordner in der Hauptebene auswählen oder auch welche eine Ebene darunter?
Public Sub Daten_aus_Protokollen_kopieren()
    
    Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
    Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
    Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
    
    Dim oWkb1 As Workbook, oWks1 As Worksheet, oWks0 As Worksheet
    Dim objFileDialog As FileDialog
    Dim aCells As Variant, iNextLine As Long, i As Long
    Dim StatusCalc As XlCalculation
    Dim avntFolders() As Variant, sXlsPath As String
    Dim strFile As String
    Dim ialngFolders As Long
    
    sXlsPath = ThisWorkbook.Path & "\" 'Datei im gleichen Ordner wie Auswertungsdateien
    
    If MsgBox("Alle Unterordner durchsuchen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
        
        avntFolders = GetFolders(sXlsPath) 'Hauptordner und alle Unterordner
        
        Redim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 1)
        
        avntFolders(UBound(avntFolders)) = sXlsPath
        
        Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
        
    Else
        
        If MsgBox("Nur bestimmten Unterordner durchsuchen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
            
            Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
            
            With objFileDialog
                .InitialFileName = sXlsPath
                .InitialView = msoFileDialogViewSmallIcons
                .Title = "Ordner auswählen"
                If .Show Then
                    
                    avntFolders = GetFolders(.SelectedItems(1) & "\") 'Unterordner und seine Unterordner
                    
                    Redim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 2)
                    
                    avntFolders(UBound(avntFolders) - 1) = .SelectedItems(1) & "\"
                    
                    avntFolders(UBound(avntFolders)) = sXlsPath
                    
                    Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
                    
                Else
                    Exit Sub
                End If
            End With
            
        Else
            
            avntFolders = Array(sXlsPath) 'Nur Hauptordner ohne Unterordner
            
        End If
    End If
    
    'Makrobremsen lösen - Am Beginn eines Makros
    With Application
        .EnableEvents = False
        StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen
    Range("A4:I1000").ClearContents
    
    Set oWks0 = ActiveSheet
    
    aCells = Split(Zellen, ",")
    
    iNextLine = iStartZeile
    
    For ialngFolders = LBound(avntFolders) To UBound(avntFolders)
        
        strFile = Dir$(avntFolders(ialngFolders) & "*.xlsx")
        
        Do Until strFile = vbNullString
            
            Set oWkb1 = Workbooks.Open(avntFolders(ialngFolders) & strFile)
            Set oWks1 = oWkb1.Sheets(1)
            
            For i = 0 To UBound(aCells)
                oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = _
                    oWks1.Range(aCells(i)).Value
            Next
            
            Call oWkb1.Close(SaveChanges:=False)
            
            iNextLine = iNextLine + 1
            
            strFile = Dir$
            
        Loop
    Next
    
    Set oWks0 = Nothing
    Set oWks1 = Nothing
    Set oWkb1 = Nothing
    
    'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
    With Application
        .EnableEvents = True
        .Calculation = StatusCalc
        .ScreenUpdating = True
    End With
End Sub

Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
16.02.2019 18:15:18
Roman
Hallo Nepumuk,
nur in der Hauptebene. Trotz allem hast du mir schon extrem weitergeholfen, ich bin dir sehr dankbar dafür.
Gruß
Roman
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 13:37:53
Nepumuk
Hallo Roman,
teste mal die Mappe im Anhang: https://www.herber.de/bbs/user/127704.xlsm
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 17:37:40
Roman
Hallo Nepumuk,
das schaut schon sehr genial aus muss ich sagen. Aber leider wenn ich alle Unterordner des Hauptordners (in meinem Fall z. B. 3 Stück) auswähle, werden nur ein Teil der Dateien abgefragt. Wähle ich einen oder zwei Unterordner, funktioniert es schon.
Gruß
Roman
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 17:54:42
Nepumuk
Hallo Roman,
kann ich nicht nachvollziehen. Ich muss mal noch ein paar Ordner anlegen. Wenn du alle Unterordner auswerten willst, dann beantworte die 1. MsgBox mit ja.
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 18:00:28
Roman
Hallo Nepumuk,
da hast du auch Recht. An dieser Stelle danke ich dir vielmals, du hast mir extrem weitergeholfen und das Leben um ein Stück weit erleichtert :)
Gruß und schönen Sonntag noch
Roman
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 18:03:00
Nepumuk
Hallo Roman,
jetzt mit 3 Ordnern habe ich den Fehler gefunden.
Ersetze diese Zeile:
lngCount = ialngFolders
durch diese:
lngCount = lngCount + ialngFolders
Gruß
Nepumuk
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 18:20:46
Roman
Hallo Nepumuk,
vielen vielen Dank an dieser Stelle. Jetzt muss ich nicht mehr drauf achten, ausversehen doch mal alle Unterordner auszuwählen. Wirklich reife Leistung, was manche hier im Forum vollbringen.
Eines noch, liege ich da richtig, wenn ich diese 2 Zeilen ausklammere, damit ich die Berücksichtigung des Hauptordners abschalte?
'ReDim Preserve avntFolders(LBound(avntFolders) To UBound(avntFolders) + 1)
'avntFolders(UBound(avntFolders)) = sXlsPath
Funktionieren tut es so, aber ist es der richtige Weg?
Und kannst du mir kurz erklären, was folgende Zeile bewirkt und ob sie nötig ist
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef psa() As Any) As Long
Gruß
Roman
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 18:39:07
Roman
Hallo Nepumuk,
mein Fehler, muss nur die Zeile 'avntFolders(UBound(avntFolders)) = sXlsPath ausklammern, habe es denk ich soweit verstanden.
Aber
Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef psa() As Any) As Long
könntest du mir noch kurz erklären :)
Gruß
Roman
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 18:54:10
Nepumuk
Hallo Roman,
1. Mit deiner 1. Vermutung lagst du richtig, du musst beide Zeilen auskommentieren.
2. Die Funktion wird benötigt um nicht in einen Fehler zu laufen wenn ein Ordner keinen Unterordner enthält. Sie liefert 0 zurück wenn das geprüfte Array nicht dimensioniert ist. Keine Angst vor DLL's, Windows und Excel benötigen hundert davon.
Gruß
Nepumuk
P.S. Wenn du meine Leistung belohnen willst, dann spende 25€ an SOS-Kinderdorf.
Anzeige
AW: Mit VBA Ordner und Unterordner abfragen
17.02.2019 23:31:57
Roman
Hallo Nepumuk,
danke für deine Rückmeldung und Hilfe.
Gruß
Roman
P.S. Habe ich gemacht :)
Anzeige
Anzeige

Infobox / Tutorial

VBA: Ordner und Unterordner durchsuchen

Schritt-für-Schritt-Anleitung

  1. Öffne Excel und starte den VBA-Editor (ALT + F11).
  2. Füge ein neues Modul hinzu: Rechtsklick im Projektfenster auf "VBAProject (DeineDatei.xlsx)" > Einfügen > Modul.
  3. Kopiere den folgenden Code in das Modul:
Option Explicit

Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef psa() As Any) As Long

Public Sub Daten_aus_Protokollen_kopieren()
    Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
    Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
    Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen
    Dim oWkb1 As Workbook, oWks1 As Worksheet, oWks0 As Worksheet
    Dim objFileDialog As FileDialog
    Dim aCells As Variant, iNextLine As Long, i As Long
    Dim StatusCalc As XlCalculation
    Dim avntFolders() As Variant, sXlsPath As String
    Dim strFile As String
    Dim ialngFolders As Long

    sXlsPath = ThisWorkbook.Path & "\" 'Datei im gleichen Ordner wie Auswertungsdateien
    Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)

    With objFileDialog
        .InitialFileName = sXlsPath
        .InitialView = msoFileDialogViewSmallIcons
        .Title = "Ordner auswählen"
        If .Show Then
            avntFolders = GetFolders(.SelectedItems(1) & "\") 'Unterordner und seine Unterordner
            Call QuickSort(LBound(avntFolders), UBound(avntFolders), avntFolders)
        Else
            Exit Sub
        End If
    End With

    'Makrobremsen lösen - Am Beginn eines Makros
    With Application
        .EnableEvents = False
        StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen
    Range("A4:I1000").ClearContents
    Set oWks0 = ActiveSheet
    aCells = Split(Zellen, ",")
    iNextLine = iStartZeile

    For ialngFolders = LBound(avntFolders) To UBound(avntFolders)
        strFile = Dir$(avntFolders(ialngFolders) & "*.xlsx")
        Do Until strFile = vbNullString
            Set oWkb1 = Workbooks.Open(avntFolders(ialngFolders) & strFile)
            Set oWks1 = oWkb1.Sheets(1)
            For i = 0 To UBound(aCells)
                oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i).Value = oWks1.Range(aCells(i)).Value
            Next
            Call oWkb1.Close(SaveChanges:=False)
            iNextLine = iNextLine + 1
            strFile = Dir$
        Loop
    Next

    'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
    With Application
        .EnableEvents = True
        .Calculation = StatusCalc
        .ScreenUpdating = True
    End With
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As Variant()
    Dim avntFolders() As Variant
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    strPath = pvstrPath

    Do
        strFolder = Dir$(strPath & "*", vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(strPath & strFolder) And vbDirectory Then
                    ReDim Preserve avntFolders(0 To ialngIndex1)
                    avntFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = avntFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = avntFolders
End Function
  1. Schließe den VBA-Editor und gehe zurück zu Excel.
  2. Starte das Makro über den Menüpunkt "Entwicklertools" > "Makros" und wähle Daten_aus_Protokollen_kopieren.

Häufige Fehler und Lösungen

  • Fehler: Index außerhalb des gültigen Bereichs

    • Ursache: Dies tritt auf, wenn Du versuchst, auf ein Element eines Arrays zuzugreifen, das nicht existiert. Überprüfe die Schleifen und stelle sicher, dass Du innerhalb der Grenzen des Arrays bleibst.

  • Fehler: Ungültiger Pfad

    • Ursache: Der Pfad, den Du angegeben hast, existiert möglicherweise nicht. Überprüfe den sXlsPath und stelle sicher, dass der angegebene Ordner korrekt ist.

Alternative Methoden

Eine alternative Methode zur Abfrage von Ordnern und Unterordnern ist die Nutzung der FileDialog-Klasse in VBA, um dem Benutzer die Auswahl mehrerer Ordner zu ermöglichen. Dies kann jedoch nicht direkt in VBA realisiert werden, da Excel keine native Unterstützung für die Auswahl mehrerer Ordner bietet.

Praktische Beispiele

Hier ist ein einfaches Beispiel, das zeigt, wie Du den GetFolders-Befehl verwenden kannst, um alle Unterordner eines bestimmten Pfades abzurufen:

Dim folders() As Variant
folders = GetFolders("C:\Dein\Verzeichnis\")

Du kannst dann eine Schleife verwenden, um alle gefundenen Ordner zu verarbeiten.

Tipps für Profis

  • Verwende die ofso.getfolder-Methode, um den Pfad zu einem spezifischen Ordner zu erhalten. Diese Methode ist besonders nützlich, wenn Du nur einen bestimmten Ordner abfragen möchtest.
  • Nutze vba strpath, um den aktuellen Pfad dynamisch zu setzen, sodass Dein Makro flexibler wird und nicht an einen statischen Pfad gebunden ist.

FAQ: Häufige Fragen

1. Wie kann ich spezifische Unterordner abfragen? Du kannst die Funktion GetFolders anpassen, um nur bestimmte Unterordner zu durchsuchen, indem Du eine Bedingung hinzufügst, die prüft, ob der Name des Unterordners in einer vordefinierten Liste enthalten ist.

2. Was bewirkt die Zeile Private Declare PtrSafe Function SafeArrayGetDim? Diese Zeile ist notwendig, um sicherzustellen, dass Dein Code auch in 64-Bit-Versionen von Excel funktioniert. Sie prüft die Dimensionen eines Arrays, um sicherzustellen, dass Du nicht auf nicht initialisierte Arrays zugreifst.

3. Kann ich auch Dateien in den Hauptordner einbeziehen? Ja, Du kannst die Zeile, die für das Einfügen des Hauptordners in das Array zuständig ist, auskommentieren, um den Hauptordner in die Abfrage einzubeziehen.

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige