Dateien aus Ordnern einlesen Excel VBA

Hallo,

ich bräuchte ein wenig Hilfe mit einem Makro zum auslesen von Ordnerinhalten. Ein Teil des Codes habe ich bereits schon (nicht von mir selbst geschrieben):
Sub Makro_einlesen()

Range("B1:B3000").Delete 'Spalte E löschen

Dim c As Range, tmp
Dim objFSO As Object
Dim objFolder As Object
Dim strPfad As String
Dim objSubfolder As Object, colSubfolders As Object
Dim I As Integer
I = 2
Dim ws As Worksheet
Set ws = ActiveSheet
strPfad = "irgendein Pfad"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
For Each objSubfolder In colSubfolders
I = I + 1

Range("B" & I).Value = objSubfolder.Name
Next objSubfolder
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing

'eingelesene Ordner sortieren

ActiveSheet.Range("E3:E2000").Select
Selection.Sort Key1:=ActiveSheet.Range("B3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

MsgBox CStr(I - 2) & " Werte gefunden", vbOKOnly, "Erfolgreich"

End Sub
Das Makro schaut in dem Pfad nach allen Ordnern und schreibt die Namen in Spalte B. Nun existieren in manchen Ordnern ein Pdf File oder manchmal auch noch ein Word File. Da müssten dann entsprechende Kreuze gesetzt werden (die Files habe alle unterschiedliche Namen, ich müsste nur wissen ob überhaut ein File existiert). Dann wäre es noch cool, wenn man die existierenden Ordner direkt neben die Ordner von Spalte A schreiben könnte.

Danke im Vorraus.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 366050

Url: https://administrator.de/forum/dateien-aus-ordnern-einlesen-excel-vba-366050.html

Ausgedruckt am: 15.05.2025 um 19:05 Uhr

6 Kommentare

Neuester Kommentar

Beispiel:

Sub CheckFolders()
    Dim fso As Object, cell As Range, file As Object, strExt as String
    Set fso = CreateObject("Scripting.FileSystemObject")  
    
    With ActiveSheet
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            If cell.Value <> "" and fso.FolderExists(cell.Value) Then  
                cell.Offset(0, 1).Value = "x"  
                For Each file In fso.GetFolder(cell.Value).Files
                    strExt = LCase(fso.GetExtensionName(file.Name))
                    If strExt = "pdf" Then  
                        cell.Offset(0, 2).Value = "x"  
                    End If
                    If strExt = "docx" Then  
                        cell.Offset(0, 3).Value = "x"  
                    End If
                Next
            End If
        Next
    End With
End Sub

Range("B1:B3000").Delete 'Spalte E löschen

Deine Kommentare solltest du dir noch mal genau ansehen, da stimmt vorne und hinten nichts überein mit deinem Bild und den Ranges!!

Und für Programm-Code gibt es den </> Button links in der Symbolleiste! Danke.

Mit dem Beispiel solltest du jetzt aber definitiv klar kommen.

Gruß Snap

Danke erstmal für deine Hilfe, ja das mit den Kommentaren war ein wenig verpeilt.
Irgendwie klappt das nicht bei mir, woher nimmt sich das Makro den Pfad?

so habe ich das jetzt eingebunden:

Sub Makro_einlesen()

Range("B1:B3000").Delete 'Spalte B löschen  

Dim c As Range, tmp
Dim objFSO As Object
Dim objFolder As Object
Dim strPfad As String
Dim objSubfolder As Object, colSubfolders As Object
Dim I As Integer
I = 2
Dim ws As Worksheet
Set ws = ActiveSheet
strPfad = "C:\Users\niklas\Desktop\test"  
Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set objFolder = objFSO.GetFolder(strPfad)
Set colSubfolders = objFolder.Subfolders
For Each objSubfolder In colSubfolders
I = I + 1

Range("B" & I).Value = objSubfolder.Name  
Next objSubfolder
Set objFolder = Nothing
Set colSubfolders = Nothing
Set objFSO = Nothing

'eingelesene Ordner sortieren  

ActiveSheet.Range("B3:B2000").Select  
Selection.Sort Key1:=ActiveSheet.Range("B3"), Order1:=xlAscending, Header:=xlGuess, _  
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Dim fso As Object, cell As Range, file As Object, strExt As String
    Set fso = CreateObject("Scripting.FileSystemObject")  
    
    With ActiveSheet
        For Each cell In .Range("A2:A" & .Cells(Rows.Count, "A").End(xlUp).Row)  
            If cell.Value <> "" And fso.FolderExists(cell.Value) Then  
                cell.Offset(0, 1).Value = "x"  
                For Each file In fso.GetFolder(cell.Value).Files
                    strExt = LCase(fso.GetExtensionName(file.Name))
                    If strExt = "pdf" Then  
                        cell.Offset(0, 2).Value = "x"  
                    End If
                    If strExt = "docx" Then  
                        cell.Offset(0, 3).Value = "x"  
                    End If
                Next
            End If
        Next
    End With



MsgBox CStr(I - 2) & " Werte gefunden", vbOKOnly, "Erfolgreich"  

End Sub

woher nimmt sich das Makro den Pfad?

Schau mal auf das Bild...Der Rest ist Hausaufgabe.

Geil, vielen Dank, echt cooles Makro. Einwandfrei

Hi, ich habe wieder ein Problem. Ich möchte Fußzeilen in alle Excel Files eines Ornders einfügen. Das klappt alles soweit, leider sind alles Files passwortgeschützt. Das Macro sollte eigentlich funktionieren, macht es aber nicht...

Sub makro_filename()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean
   
    MyPath = "irgendeinpfad"  
    
    'If there are no Excel files in the folder exit the sub  
    FilesInPath = Dir(MyPath & "*.xl*")  
    If FilesInPath = "" Then  
        MsgBox "Keine Dateien gefunden"  
        Exit Sub
    End If
    'Fill the array(myFiles)with the list of Excel files in the folder  
    Fnum = 0
    Do While FilesInPath <> ""  
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    'Change ScreenUpdating, Calculation and EnableEvents  
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Loop through all files in the array(myFiles)  
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open((MyPath & MyFiles(Fnum)), , , , Password:="password")  
            
            On Error GoTo 0
            If Not mybook Is Nothing Then

                'Change cell value(s) in all worksheets in mybook  
    On Error Resume Next
    For Each sh In mybook.Worksheets
        If sh.ProtectContents = False Then
            With sh
        
                .PageSetup.LeftFooter = "Form-Nr. " & mybook.Name  
                .Range("A7:I11").Interior.Color = RGB(224, 224, 224)  
      
                ' change footer in every worksheet  
                
            End With
        Else
            ErrorYes = True
        End If
    Next sh

                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    
                    'Close mybook without saving  
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook  
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook  
                ErrorYes = True
            End If
        Next Fnum
    End If
    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _  
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"  
    End If
    'Restore ScreenUpdating, Calculation and EnableEvents  
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
 