Alle Dateien eines Ordners...

Alle Dateien eines Ordners (optional mit Unterordner) werden aufgelistet. Ist es keine Exceldatei wird der Dateityp in die Zelle geschrieben. Ist es eine Exceldatei - prüfen, ob ein bestimmtes Tabellenblatt vorhanden ist. Wenn das Tabellenblatt vorhanden ist - Wert aus A3 in Zelle schreiben, sonst Info in Zelle schreiben.

All files in a folder (optionally with subfolders) are listed. If it is not an excel file, the data type is written into the cell. Is it an Excel file - check if a particular spreadsheet is present. If the sheet exists, write value from A3 to cell, otherwise write info to cell.

Hier noch eine Beispieldatei / Here's a sample file:
Alle Dateien eines Ordners...[ZIP 2 MB]

Option Explicit
' Informationsausgabe
Const strInfo1 As String = "Keine Exceldatei!"
Const strInfo2 As String = "Nicht vorhanden!"
' Tabellenblatt das geprüft werden soll
Const strSheet As String = "Tabelle1"
' Suchmuster gegebenenfalls anpassen
Const strEX As String = "*.*"
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 09.10.2016
' Purpose   : Alle Dateien eines Ordners - Optional mit Unterordner...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Mit Ordnerauswahldialog
     strDir = fncFolder("C:\")
    ' Datei im gleichen Ordner wie Auswertungsdateien
    ' strDir = ThisWorkbook.Path & "\"
    ' Fester Ordner vorgegeben
    ' strDir = "C:\Temp\Stick\"
    ' strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    If strDir <> "" Then
        Tabelle1.Rows("2:" & Tabelle1.Rows.Count).ClearContents
        Set objDir = objFSO.getfolder(strDir)
        dirInfo objDir, strEX, True ' Mit Unterordner
    ' dirInfo objDir, strEX ' Ohne Unterordner
    End If
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : dirInfo
' Author    : Case (Ralf Stolzenburg)
' Date      : 09.10.2016
' Purpose   : Rekursive Funktion alle Dateien...
'--------------------------------------------------------------------------
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objMappe As Object
    Dim lngLastRow As Long
    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
                    ' Der Code bezieht sich auf ein bestimmtes Objekt
                    ' Hier Tabelle1 = Objektname - Name VOR der Klammer
                    ' Alles was sich auf dieses "With" bezieht
                    ' MUSS mit einem Punkt beginnen
                    With Tabelle1
                        ' Letzte Zeile bezogen auf Spalte A plus 1
                        lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                            .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                        If varTMP.Type Like "*Excel*" 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
                            ' Pfad- und Dateiname in Spalte A schreiben
                            .Cells(lngLastRow, 1).Value = varTMP.Path
                            ' Datei ausgeblendet öffnen
                            Set objMappe = GetObject(varTMP.Path)
                            ' Prüfen, ob Tabellenblatt vorhanden
                            If fncSheetEx(varTMP.ParentFolder.Path, varTMP.Name, strSheet) = True Then
                                With .Cells(lngLastRow, 2)
                                    .Value = objMappe.Worksheets(strSheet).Range("A3").Value
                                    .Font.ColorIndex = 3
                                End With
                            Else
                                With .Cells(lngLastRow, 2)
                                    .Value = strInfo2
                                    .Font.ColorIndex = 3
                                End With
                            End If
                            objMappe.Close False
                            Set objMappe = Nothing
                            ' Debug.Print "Pfad: " & varTMP.ParentFolder.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
                        Else
                            ' Pfad- und Dateiname in Spalte A schreiben
                            .Cells(lngLastRow, 1).Value = varTMP.Path
                            ' Dateityp in Spalte B schreiben
                            .Cells(lngLastRow, 2).Value = varTMP.Type
                            ' Optional - Information1 in Spalte B schreiben
                            ' .Cells(lngLastRow, 2).Value = strInfo1
                        End If
                    End With
                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
    Set objMappe = Nothing
End Sub
' Funktion um einen Ordner auszzuwählen
Private Function fncFolder(strPath As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = strPath
        .Title = "Folder"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strPath = .SelectedItems(1)
            If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        Else
            strPath = ""
        End If
    End With
    fncFolder = strPath
End Function
' Funktion um das Vorhandensein von Tabellenblättern zu prüfen
' Evaluate wertet einen String aus
' ISREF ist eine Worksheet Funktion die True/False bezogen auf
' eine gültige Zellreferenz zurückliefert
Private Function fncSheetEx(ByVal strPath As String, ByVal strFile As String, ByVal strSheet As String) As Boolean
    On Error Resume Next
    fncSheetEx = Evaluate("ISREF(" & "'" & strPath & "\" & "[" & strFile & "]" & strSheet & "'" & "!A1)")
    Err.Clear
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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