Geschlossene Dateien - drei und mehrere Zellen (Array) auslesen...

Frage: Aus allen Dateien eines Ordners (optional mit Unterordner) werden drei Zellen per Formelverweis ausgelesen. Die Werte sollen in Spalte A (C5), Spalte B (G7) und Spalte C (J12) eingefügt werden. Es können aber auch mehr Zellen werden. Wie geht das? (Bei mehr als 2 bis 3 Zellen nutzen wir ein Array mit Schleife - siehe zweiten Code).

From all files in a folder (optionally with subfolders) three cells are read using a formula reference. The values ​​to be inserted in column A, column B and column C. But it may also be more cells. How does it work? (With more than 2 to 3 cells, we use an array with loop - see second code).

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - drei und mehrere Zellen (Array) auslesen...[ZIP 80 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Werte"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Tabelle1"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C5"
' Die Zelle wird ausgelesen
Const strCellQ2 As String = "G7"
' Die Zelle wird ausgelesen
Const strCellQ3 As String = "J12"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - drei Zellen auslesen...
'--------------------------------------------------------------------------
Public Sub Files_Read()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    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
    ' Bei Bedarf!!!!!!
    ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
    With ThisWorkbook.Worksheets(strSheetZ)
        .Rows("2:" & .Rows.Count).ClearContents
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' Mit Unterordner
    dirInfo objDir, "*.xls*", True
    ' Ohne Unterordner
    'dirInfo objDir, "*.xls*"
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      : 29.10.2013
' Purpose   : Geschlossene Dateien - drei Zellen auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub - Optional mit Unterordner
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
    ' Alle Dateien im vorgegebenen Ordner
    For Each varTMP In objCurrentDir.Files
        ' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
        ' Falls im gleichen Ordner
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            ' Prüfe, ob es eine temporäre Datei ist
            If 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 A plus 1
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 1)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte A
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ1
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                        ' Hier würde jetzt noch der Dateiname in Spalte D geschrieben
                        '.Offset(0, 3).Value = varTMP.Name
                        ' Hier würde jetzt noch der Dateiname mit Pfad in Spalte D geschrieben
                        '.Offset(0, 3).Value = varTMP.Path
                    End With
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 2)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte B
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ2
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                    End With
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 3)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte B
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ3
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                    End With
                End With
            End If
        End If
    Next
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read" 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

Zweites Beispiel bei mehreren Zellen - Array / Second example with multiple cells - array.

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Werte"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Tabelle1"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen...
'--------------------------------------------------------------------------
Public Sub Files_Read_1()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    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")
    ' 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      : 29.10.2013
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen...
'--------------------------------------------------------------------------
' 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("A2", "A9", "B3", "B11", "C5", "D9", "G7", "J12")
    ' 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
        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 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...
                    .Cells(lngLastRow, intTMP + 1).Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & strSheetQ & "'!" & arrCell(intTMP)
                Next intTMP
            End With
        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

  1. Hallo zusammen,
    wie schaffe ich es, dass die Daten erst in Zeile 10 und nicht in Zeile 2 eingelesen werden?

    Viele Grüße
    KS

    AntwortenLöschen

Kommentar veröffentlichen

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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