Alle Dateien eines Ordners - Optional mit Unterordner

Frage: Kann mir mal jemand ein Grundgerüst an die Hand geben, mit dem alle Dateien eines Ordners (optional mit Unterordner) berücksichtigt werden.

Option Explicit
' Suchmuster gegebenenfalls anpassen 
Const strEX As String = "*.xls*"
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Files_Read 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Alle Dateien eines Ordners - Optional mit Unterordner... 
'-------------------------------------------------------------------------- 
Public Sub Files_Read()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien 
    ' strDir = ThisWorkbook.Path & "\" 
    ' Fester Ordner vorgegeben 
    strDir = "C:\Temp\Test\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.getfolder(strDir)
    'dirInfo objDir, strEX, True ' Mit Unterordner 
    dirInfo objDir, strEX ' Ohne Unterordner 
Fin:
    With Application
        ' Bei Bedarf 
        '.Goto (ThisWorkbook.Worksheets(1).Range("A1")), True 
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : dirInfo 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Rekursive Funktion alle Dateien... 
'-------------------------------------------------------------------------- 
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName Then
            If varTMP.Name <> ThisWorkbook.Name Then
                If Left(varTMP.Name, 1) <> "~" Then
                    ' Hier jetzt der Code um mit der Datei etwas zu machen 
                    ' z. B. Öffnen, etwas auslesen oder was auch immer... 
                    ' Im folgenden werden nur ein paar Informationen 
                    ' im Direktfenster (VBE - STRG+G) ausgegeben 
                    ' Diese Zeilen mit Debug.Print können natürlich 
                    ' gelöscht bzw. auskommentiert werden 
                    Debug.Print "Pfad: " & varTMP.ParentFolder.Path
                    Debug.Print "Pfad & Datei: " & varTMP.Path
                    Debug.Print "Name: " & varTMP.Name
                    Debug.Print "Erstelldatum: " & varTMP.DateCreated
                    Debug.Print "Letzter Zugriff: " & varTMP.DateLastAccessed
                    Debug.Print "Letzte Änderung: " & varTMP.DateLastModified
                    Debug.Print "Größe in Byte: " & varTMP.Size
                    Debug.Print "Type: " & varTMP.Type
                    Debug.Print "Anzahl ALLE: " & varTMP.ParentFolder.Files.Count
                    Debug.Print vbCrLf
                End If
            End If
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Excel -> Word in Textmarken (Bookmarks)...