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

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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