Beiträge

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

02.08.2016

Unterschiedliche Textfelder in Word aus Excel befüllen...

Ein einfaches Beispiel - unterschiedliche Textfelder in einem Word Dokument füllen mit Daten aus Excel.

A simple example - different text fields in a Word document, fill it with data from Excel.

Hier noch eine Beispieldatei / Here's a sample file:
Unterschiedliche Textfelder in Word aus Excel befüllen...[ZIP 100 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 02.08.2016
' Purpose   : Word - Datei öffnen, verschiedene Textfelder befüllen...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim strPathFile1 As String
    Dim strPathFile As String
    Dim strBookmark As String
    Dim objWDDocV As Object
    Dim objWDDoc As Object
    Dim objWDApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell"
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken
        .DisplayAlerts = False
    End With
    ' Pfad und Dateiname der WordVORLAGE. Diese ist im selben Ordner
    ' wie die Exceldatei mit dem Code
    strPathFile1 = ThisWorkbook.Path & Application.PathSeparator & _
        "Textfelder_befuellen_aus_Excel.dotx"
    ' Pfad und Dateiname der Worddatei. Diese ist im selben Ordner
    ' wie die Exceldatei mit dem Code
    strPathFile = ThisWorkbook.Path & Application.PathSeparator & _
        "Textfelder_befuellen_aus_Excel.docx"
    ' Die Wordapplikation sichtbar starten
    Set objWDApp = OffApp("Word", False)
    If Not objWDApp Is Nothing Then
        ' Worddatei öffnen und auf Objektvariable festlegen
        Set objWDDoc = objWDApp.Documents.Open(strPathFile, , True)
        ' Worddatei aus Vorlage öffnen und auf Objektvariable festlegen
        Set objWDDocV = objWDApp.Documents.Add(Template:=strPathFile1)
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier das Worddokument
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With objWDDoc
            .FormFields("Text1").Result = "Text1"
            .TextBox1.Text = "Text2"
            .ContentControls(1).Range.Text = "Text3"
            .ContentControls(2).Range.Text = "Text4"
            .Shapes("Text Box 1").TextFrame.TextRange.Text = "Text5"
        End With
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier das Worddokument, das aus der Vorlage erstellt wurde
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With objWDDocV
            .FormFields("Text1").Result = "Text1"
            .TextBox1.Text = "Text2"
            .ContentControls(1).Range.Text = "Text3"
            .ContentControls(2).Range.Text = "Text4"
            .Shapes("Text Box 1").TextFrame.TextRange.Text = "Text5"
        End With
    End If
    ' Die folgende Codezeile KANN raus, WENN die Datei dann z. B.
    ' gespeichert und geschlossen wird, also ein kompletter
    ' Durchgang gemacht wird
    ' IN UNSEREM BEISPIEL HIER NATÜRLICH NICHT!
    objWDApp.Visible = True
Fin:
    ' Objektvariablen zurücksetzen
    Set objWDDocV = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' Bildschirmaktualisierung wieder einschalten
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 02.08.2016
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            objApp.Visible = blnVisible
    End Select
    Set OffApp = objApp
    Set objApp = Nothing
End Function

18.01.2016

Outlook - Ordner im Postein- und Postausgang erstellen...

Outlook - Ordner im Posteingang und Postausgang erstellen. Wie geht das?

Create a folder in your Inbox and Outbox - Outlook. How does it work?

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 18.01.2016
' Purpose   : Outlook - Ordner unter Postein- und Postausgang erstellen...
'--------------------------------------------------------------------------
Sub Main()
    Dim objNewFolder As Object
    Dim varFolder As Variant
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objName As Object
    Dim blnTMP As Boolean
    On Error GoTo Fin
    varFolder = Application.InputBox("Ordnername?", Type:=2)
    If Not varFolder = False And Trim(varFolder) <> "" Then
        Set objOutApp = CreateObject("Outlook.Application")
        Set objName = objOutApp.GetNamespace("MAPI")
        ' 6 = olFolderInbox
        ' 4 = olFolderOutbox
        On Error Resume Next
        Set objFolder = objName.GetDefaultFolder(6)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
        If Err.Number = 440 Then blnTMP = True
        Err.Clear
        On Error GoTo Fin
        Set objFolder = objName.GetDefaultFolder(4)
        Set objNewFolder = objFolder.Folders.Add(varFolder)
    End If
Fin:
    Select Case Err.Number
        Case 440
            MsgBox "Ordner bereits vorhanden!"
        Case 0
        Case Else
            MsgBox "Fehler: " & Err.Number & " " & Err.Description
    End Select
    Set objNewFolder = Nothing
    Set objFolder = Nothing
    Set objName = Nothing
    Set objOutApp = Nothing
End Sub
' Nachfolgend die Elemente bzw. Konstanten von "OlDefaultFolders"
' Entnommen aus Objektkatalog (F2 im VBA-Editor) in Outlook 2010
'Const olFolderCalendar = 9
'Const olFolderConflicts = 19 (&H13)
'Const olFolderContacts = 10
'Const olFolderDeletedItems = 3
'Const olFolderDrafts = 16 (&H10)
'Const olFolderInbox = 6
'Const olFolderJournal = 11
'Const olFolderJunk = 23 (&H17)
'Const olFolderLocalFailures = 21 (&H15)
'Const olFolderManagedEmail = 29 (&H1D)
'Const olFolderNotes = 12
'Const olFolderOutbox = 4
'Const olFolderRssFeeds = 25 (&H19)
'Const olFolderSentMail = 5
'Const olFolderServerFailures = 22 (&H16)
'Const olFolderSuggestedContacts = 30 (&H1E)
'Const olFolderSyncIssues = 20 (&H14)
'Const olFolderTasks = 13
'Const olFolderToDo = 28 (&H1C)
'Const olPublicFoldersAllPublicFolders = 18 (&H12)

04.01.2016

UserForm - Datum - Filtern - als PDF speichern...

In Spalte A steht fortlaufend das Datum. Dies soll über eine UserForm gefiltert und als PDF gespeichert werden.

In column A continuously is the date. This should be filtered through a UserForm and saved as a PDF.

Hier noch eine Beispieldatei / Here's a sample file:
UserForm - Datum - Filtern - als PDF speichern...[XLSM 60 KB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : UserForm_Activate
' Author    : © Case (Ralf Stolzenburg)
' Date      : 04.01.2016
' Purpose   : Bereich - Datum - Filtern - PDF speichern...
'--------------------------------------------------------------------------
Private Sub UserForm_Activate()
    ' Tabelle1 Spalte A in Combobox schreiben
    ComboBox1.List = Tabelle1.Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ' Inhalt ComboBox2 = ComboBox1
    ComboBox2.List = ComboBox1.List
    ' Eintrag in ComboBox1 komplett markieren - ersten Eintrag anzeigen
    With ComboBox1
        .ListIndex = 0
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox1)
    End With
    ' 16ten Eintrag von ComboBox2 anzeigen (Zählung beginnt bei 0)
    ComboBox2.ListIndex = 15
End Sub
Private Sub CommandButton1_Click()
    ' Variablendeklaration
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Wenn ComboBox1 oder 2 leer ist - Meldung ausgeben
    If Me.ComboBox1.Text = "" Or Me.ComboBox2.Text = "" Then
        If Me.ComboBox1.Text = "" Then
            MsgBox "Startdatum angeben!"
            Me.ComboBox1.SetFocus
        Else
            MsgBox "Enddatum angeben!"
            ComboBox2.SetFocus
        End If
    Else
        ' Der Code bezieht sich auf ein bestimmtes Objekt
        ' Hier Tabelle1 = der CodeName der Tabelle
        ' Im VBA-Editor der Name VOR der Klammer - Tabelle1 (Tabelle1)
        ' im englischen Excel in der Regel Sheet1
        ' Alles was sich auf dieses "With" bezieht
        ' MUSS mit einem Punkt beginnen
        With Tabelle1
            ' Filtern und als PDF auf dem Desktop speichern
            .Range("A1").AutoFilter Field:=1, _
            Criteria1:=">=" & CDbl(DateValue(ComboBox1)), _
            Operator:=xlAnd, Criteria2:="<=" & CDbl(DateValue(ComboBox2))
            .ExportAsFixedFormat 0, Environ("UserProfile") & _
                "\Desktop\" & Left(ThisWorkbook.Name, _
                (InStrRev(ThisWorkbook.Name, ".") - 1)) & _
                Format(Now, "_DD.MM.YYYY"), , , , , , False
            ' Wenn Autofilter und gefiltert dann alle Daten zeigen
            If .AutoFilterMode And .FilterMode Then .ShowAllData
            ' Autofilter löschen
            .Rows.AutoFilter
            ' Seitenumbruchlinien ausblenden
            .DisplayAutomaticPageBreaks = False
        End With
    End If
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
    ' und die Fehlerbeschreibung aus
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub ComboBox2_DropButtonClick()
    ' Eintrag in ComboBox2 komplett markieren
    With ComboBox2
        .SetFocus
        .SelStart = 0
        .SelLength = Len(ComboBox2)
    End With
End Sub
Private Sub CommandButton2_Click()
    ' UserForm entladen
    Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' Schliessen über das "x" unterbinden
    If CloseMode = 0 Then Cancel = True
End Sub

27.08.2015

Geschlossene Dateien - Range und Summe bestimmter Zellen...

Geschlossene Dateien. Zellen werden über ein Array ausgelesen - inklusive Unterordner (optional). Bestimmte Zellen werden summiert. Nur Dateien die einem bestimmten Muster folgen, werden eingelesen. In diesem Beispiel - kein "eta" im Dateiname. Die Summe wird über "ExecuteExcel4Macro" realisiert.

Closed files. Cells are read on an array - including subfolders (optional). Certain cells are summed. Only files that follow a certain pattern are read. In this example - no "eta" in the File Name. The sum will be implemented via "ExecuteExcel4Macro".

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Range und Summe bestimmter Zellen...[ZIP 900 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Werte"
' Diese Zellen werden Summiert
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    Dim objShell As Object
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        blnUpdate = .AskToUpdateLinks
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Wenn Du einen Ordnerauswahldialog möchtest
    'Set objShell = CreateObject("Shell.Application")
    'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
    'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
    'strDir = varDir.Self.Path
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier strSheetZ
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
        .Rows("2:" & .Rows.Count).ClearContents
        ' Mit Unterordner
        dirInfo objDir, "*.xls*", True
        ' Ohne Unterordner
        'dirInfo objDir, "*.xls*"
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = blnUpdate
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : © Case (Ralf Stolzenburg)
' Date      : 27.08.2015
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen - Array...
'--------------------------------------------------------------------------
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    ' Variablendeklaration
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim arrCell As Variant
    Dim intTMP As Integer
    Dim varTMP As Variant
    ' Weitere Zellen nach gleichem Muster in das Array einfügen
    arrCell = Array("A1", "C1", "E2", "H8", "I8", _
        "H16", "I16", "H24", "I24", "H32", "I32", "C8", _
        "D8", "C16", "D16", "C24", "D24", "C32", "D32")
    ' Alle Dateien im vorgegebenen Ordner
    For Each varTMP In objCurrentDir.Files
        ' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
        ' Falls im gleichen Ordner und ist KEINE temporäre Datei
        ' Dateiname mit "eta" im Namen werden NICHT eingelesen!!!!!
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            If Not varTMP.Name Like "*eta*" Then
                ' Der Code bezieht sich auf ein bestimmtes Objekt
                ' Hier strSheetZ
                ' Alles was sich auf dieses "With" bezieht
                ' MUSS mit einem Punkt beginnen
                With ThisWorkbook.Worksheets(strSheetZ)
                    ' 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
                    ' Schleife über alle Zellen des Arrays
                    For intTMP = LBound(arrCell) To UBound(arrCell)
                        ' Hier würde jetzt noch der Dateiname mit Pfad
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
                        ' Hier würde jetzt noch der Dateiname
                        ' in die nächste freie Spalte geschrieben
                        '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
                        ' Werte über Formel holen, Tabellenblatt über "Const..."
                        ' oben definiert, Zelle über Array. Formel in Spalte A folgende...
                        strFormula = "'" & Mid(varTMP.Path, 1, InStrRev(varTMP.Path, "\")) & _
                            "[" & Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & strSheetQ & "'!"
                        .Cells(lngLastRow, intTMP + 1).Formula = "=" & strFormula & arrCell(intTMP)
                    Next intTMP
                    .Cells(lngLastRow, 20).Value = ExecuteExcel4Macro(strFormula & "R18C6") + _
                        ExecuteExcel4Macro(strFormula & "R26C6") + _
                        ExecuteExcel4Macro(strFormula & "R34C6")
                    .Cells(lngLastRow, 21).Value = ExecuteExcel4Macro(strFormula & "R21C6") + _
                        ExecuteExcel4Macro(strFormula & "R29C6") + _
                        ExecuteExcel4Macro(strFormula & "R37C6")
                End With
            End If
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub