Geschlossene Dateien bestimmte Zellen auslesen

Frage: In eine Masterdatei sollen der Inhalt von 4 bestimmten Zellen aus allen Dateien eines Ordners (Optional mit Unterordner) eingelesen werden. Der Pfad- und Dateiname soll in der ersten Spalte als Kommentar eingefügt werden. Wie geht das?

Hier noch eine Beispieldatei: Geschlossene Dateien bestimmte Zellen auslesen...

Option Explicit
Const strSheetQ As String = "Sheet1" ' Die Tabelle wird ausgelesen 
Const strSheetZ As String = "Total" ' Die Tabelle ist in DIESER Datei 
Const strCellQ1 As String = "A1" ' Die Zelle wird ausgelesen 
Const strCellQ2 As String = "A5" ' Die Zelle wird ausgelesen 
Const strCellQ3 As String = "B8" ' Die Zelle wird ausgelesen 
Const strCellQ4 As String = "C20" ' Die Zelle wird ausgelesen 
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Files_Read 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 10.10.2012 
' Purpose   : Geschlossene Dateien bestimmte Zellen auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Files_Read()
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    ' Die Application wird "stillgelegt" 
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .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)
        ' Ab Zeile 4 abwärts wir alles gelöscht 
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner 
        dirInfo objDir, "*.xls*" ' Ohne Unterordner 
        ' Formeln in Werte umwandeln 
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Die Application wird wieder zum Leben erweckt 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    ' Objektvariable(n) leeren 
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Etwaig auftretende Fehler ausgeben 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        ' Dateiname ist im Bereich der übergebenen Variablen "strName" 
        ' UND entspricht nicht dem Namen DIESER Datei 
        ' falls diese im gleichen Ordner ist 
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            ' Auch TEMPORÄRE Dateien werden ausgeschlossen 
            ' Diese beginnen in der Regel mit einer Tilde 
            If Not Left(varTMP.Name, 1) = "~" Then
                With ThisWorkbook.Worksheets(strSheetZ)
                    ' Letzte belegte Zeile ermitteln, dann + 1 
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Formel in lngLastRow Spalte A  reinschreiben 
                    With .Cells(lngLastRow, 1)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ1
                        .ClearComments
                        .AddComment
                        .Comment.Visible = False
                        .Comment.Text Text:=varTMP.Path
                    End With
                    ' Formel in lngLastRow Spalte B  reinschreiben 
                    With .Cells(lngLastRow, 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ2
                    End With
                    ' Formel in lngLastRow Spalte C  reinschreiben 
                    With .Cells(lngLastRow, 3)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ3
                    End With
                    ' Formel in lngLastRow Spalte D  reinschreiben 
                    With .Cells(lngLastRow, 4)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ4
                    End With
                End With
            End If
        End If
    Next varTMP
    ' Je nach Angabe oben werden hier auch Unterordner durchsucht 
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
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)...