29.10.2013

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

1 Kommentar:

  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

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...