09.10.2016

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...