Geschlossene Dateien - Range in Masterdatei in Zeilen auslesen...

Frage: Bestimmte Daten (B2:C2, B3:C3, B4:C4) aus über 200 Exceldateien in eine Masterdatei in A2 abwärts. Der Dateiname in Spalte A, der Rest in die Spalten B:G. Wie geht das?

Certain data (B2:C2, B3:C3, B4:C4) from over 200 Excel files into a master file in A2 down. The file name in column A and the rest in columns B:G. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Range in Masterdatei in Zeilen auslesen...[ZIP 300 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 = "Total"
' Dieser Bereich wird ausgelesen
Const strRange1 As String = "B2:C2"
Const strRange2 As String = "B3:C3"
Const strRange3 As String = "B4:C4"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 24.04.2014
' Purpose   : Geschlossene Dateien Range auslesen...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    ' 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
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
     strDir = ThisWorkbook.Path & Application.PathSeparator
    ' Fester Ordner vorgegeben
    'strDir = "C:\Temp\Test\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.GetFolder(strDir)
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt (bzw. die Variable) strSheetZ
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With ThisWorkbook.Worksheets(strSheetZ)
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
        dirInfo objDir, "*.xls*" ' Ohne Unterordner
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' 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      : 24.04.2014
' Purpose   : Geschlossene Dateien - Range auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub - Optional mit Unterordner
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
    ' 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
        ' Dafür die Abfrage nach der Tilde "~"
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" 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 B plus 1
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                    .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
                ' Dateiname mit Pfadangabe
                '.Cells(lngLastRow, 1).Value = varTMP.Path
                ' Hier nur Dateiname ohne Pfadangabe
                .Cells(lngLastRow, 1).Value = varTMP.Name
                ' Werte über Formel holen, Tabellenblatt über "Const..."
                ' oben definiert, Range auch oben definiert.
                ' Formel in Spalte B:G. Datumsformat setzen
                With .Range(.Cells(lngLastRow, 2), .Cells(lngLastRow, 3))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange1
                End With
                With .Range(.Cells(lngLastRow, 4), .Cells(lngLastRow, 5))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange2
                End With
                With .Range(.Cells(lngLastRow, 6), .Cells(lngLastRow, 7))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange3
                End With
            End With
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Main" vorgegeben)
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    ' Setze die Objektvariable auf Nothing
    Set objWorkbook = Nothing
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)...