10.10.2012

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...