Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
25.04.2024 21:21:16
Zellkommentar in UserForm anzeigen und bearbeiten
25.04.2024 21:13:13
Kalenderwochen addieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1672to1676
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1672to1676
1672to1676
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

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

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
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
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 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
Anzeige
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
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
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
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
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.
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 :)

149 Forumthreads zu ähnlichen Themen

Dateiname oder Pfad zu lang
chris

Hallo zusammen,
ich habe eine frage und hoffe wieder einmal auf eure Gute Hilfe.
Hat bis jetzt schom immer geklappt.ich seid echt super.
ich will eine Datei Speichern.
Mit dem Code.
newwb.SaveAs Filename:= ""
Der Pfad in dem ich die Exceldatei speichern will ist sehr lan...
07.05.2009 11:06:20
Thread-ID: 1073532
6 Beiträge
Anzeige
VBA-Ordner in Ordnerstruktur suchen
andreas

Hallo zusammen,
ich möchte den Ordner mit Wert aus Zelle "K12" im Laufwerk "V" suchen, wenn dieser nicht vorhanden ist "false", dann Rufe ich das Formular "Ordner.show" auf und erstelle nach einer Abfrage den Ordner mit "ChDir "J:\...".
Ist die suche "true" dann mach ich mit der routin...
23.02.2010 13:16:03
Thread-ID: 1140663
5 Beiträge
VBA: Datei suchen (inkl. Unterordner)
Katharina

Hallo zusammen
Die Frage wurd hier schonmal so ähnlich gestellt, aber ich bekomme das ganze einfach nicht ans laufen.
https://www.herber.de/forum/archiv/1220to1224/t1221650.htm
Hier mein Problem:
In Spalte A stehen Identifikationsnummern, z.B. 123, 456, 567 etc
Nun möchte...
02.10.2012 11:11:05
Thread-ID: 1280211
15 Beiträge
Anzeige
VBA auslesen von Dateien ohne sie zu öffnen
Dateien

Hallo, ich absoluter Anfänger in VBA, bin dabei mich einzuarbeiten, allerdings habe ich ziemlichen Stress damit ich mein Projekt zum Abschluss bringen kann.
Ich habe hier im Archiv folgendes Programm gefunden, was auch an sich gut funktioniert: Sub AuslesenGeschlDatei() Dim rng As Range, _...
09.10.2013 20:43:38
Thread-ID: 1333850
3 Beiträge
mittels button eine pdf Datei suchen und drucken
Gerhard

Hallo alle,
ich habe in einem Ordner mit Pfad "W:\Datenverwaltung\Wareneingang\Prüfzeugnisse" viele pdf-Dateien. Der Dateiname setzt sich wie folgt zusammen:
4- oder 5-stellige Zahl, dann ein Leerzeichen und danach unterschiedlicher Text.
Nun gebe ich in einer Excel-Tabelle in Zelle...
31.10.2014 08:30:34
Thread-ID: 1389649
6 Beiträge
vba Bestimmten Ordner öffnen
Andre
Hallo liebes forum,
kann mir jemand eine hilfestellung geben, ich habe eine userform auf dieser ist eine textbox die wird mein öffnen automatisch gefüllt.
nun will ich den dazugehörigen ordner mit button öffnen und den inhalt anzeigen lassen.
Danke
11.01.2015 07:23:40
Thread-ID: 1402032
8 Beiträge
pdf Datei in Ordner suchen und öffnen
Milos

HILFEE:
Ich habe die Aufgabe bekommen ein Tool zu programmieren, mit dem man Schemas finden kann.
Ich habe schon jegliche Codes probiert aber ich komme nicht zum Erfolg.
Erklärung:
4 verschiedene Optionbuttons (Bei Auswahl eines Optionsbuttons macht das Programm im Hintergrund d...
16.07.2015 14:24:51
Thread-ID: 1436797
6 Beiträge
Dateiname zu Lang
Sigi

Hallo,
ich habe folgendens Problem mit den Speichern einer Datei.
sPfad : "C:\xxxx" = 136 Zeichen
sFile : "003 xxxx" = 79 Zeichen
Gesamt: 215 Zeichen
Jetzt kommt die Fehlermeldung "Auf die Datei konnte nicht zugegriffen werden...."
Da der sPfad und sFile flexibel angeleg...
15.01.2016 05:19:21
Thread-ID: 1468968
3 Beiträge
Anzeige

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge
5
1
4
14
3
2
5
7
5
2
3
2
1
1
6
1
4
5
2
2
5
4
6
3
2