Geschlossene Dateien - Range auslesen

Frage: Aus geschlossenen Exceldateien (alle eines Ordners - optional mit Unterordner) soll über VBA per Formel der Range A2:Y15 ausgelesen werden und ab Zeile 2 in einer Hauptdatei eingefügt werden. Bei erneutem ausführen des Codes sollen die alten Daten erst gelöscht werden. Ab Zeile 2, da die erste Zeile eine Überschrift enthält.

Option Explicit
Const strSheetQ As String = "Tabelle1" ' DIE Tabelle wird ausgelesen"
Const strSheetZ As String = "Gesamt" ' Die Tabelle in DIESER Datei
Const strRange As String = "A2:Y15" ' Der Bereich wird ausgelesen
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)
    With ThisWorkbook.Worksheets(strSheetZ)
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
        dirInfo objDir, "*.xls*" ' Ohne Unterordner
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objWorkbook As Workbook
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    Dim strTMP As String
    strTMP = Range(strRange).Address(RowAbsolute:=True, _
        ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                    .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                With .Range(.Cells(lngLastRow, 1), _
                    .Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
                    Range(strRange).Columns.Count))
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange
                End With
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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