2 Weitere Werte auslesen

[ThomasH78]

Servus,

ich hoffe Ihr könnt mir helfen.
Ich habe ein Makro (nicht selbst geschrieben, nur angepasst) welches sämtliche Excel Dateien im selben Ordner ausliest, Diese auflistet (Spalte A) und jeweils eine Zelle ausliest und den Wert daneben auflistet (Spalte B). Jetzt sollen noch zwei weitere Werte hinzukommen, die in Spalte C und D genauso daneben geschrieben werden. Sämtliche rumbastelei im Bereich "With - End With" mit einer zweiten Variable, die den Wert einer anderen Zelle oder gar der gleichen hatte, schlugen fehl.

------------------------------------------------------------------------------------------

Code:

Option Explicit
Const strSheetQ As String = "Monatsbericht" ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Stunden" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "I38" ' Die Zelle wird ausgelesen

Public Sub Clear_Content()

    Application.EnableEvents = False
        Worksheets("Stunden").Range("A2:A30").Value = ""
        Worksheets("Stunden").Range("B2:B30").Value = ""
    Application.EnableEvents = True

End Sub

Public Sub Files_Read_Stunden()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strDir = ThisWorkbook.Path  ' Datei im gleichen Ordner wie Auswertungsdateien
    Set objDir = objFSO.GetFolder(strDir)
    'dirInfo objDir, "*.xls", True ' Mit Unterordner
    dirInfo objDir, "*.xlsx"
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub

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
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            If Not Left(varTMP.Name, 2) = "Q_" Then
                With ThisWorkbook.Worksheets(strSheetZ)
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                        .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
                    With .Cells(lngLastRow, 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ1
                        .Value = .Value
                        .Offset(0, -1).Value = varTMP.Name
                    End With
                End With
            End If
        End If
    Next
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub

--------------------------------------------------------------------------------------------------
Besten Dank.
Thomas

   

[Kuwer]

Hallo Thomas,

Code:

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
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            If Not Left(varTMP.Name, 2) = "Q_" Then
                With ThisWorkbook.Worksheets(strSheetZ)
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                        .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
                    With .Cells(lngLastRow, 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ1
                        .Value = .Value
                        .Offset(0, -1).Value = varTMP.Name
                        With .Offset(0, 1)
                            .Formula = ...
                            .Value = .Value
                        End With
                        With .Offset(0, 2)
                            .Formula = ...
                            .Value = .Value
                        End With
                    End With
                End With
            End If
        End If
    Next
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub

[ThomasH78]

Hallo Kuwer,

ich habe die Formeln vervollständigt und natürlich funktioniert es.

Allerbesten Dank und Grüße
Thomas