10.02.2023, 09:57
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.
------------------------------------------------------------------------------------------
--------------------------------------------------------------------------------------------------
Besten Dank.
Thomas
[attachment=46964]
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 SubBesten Dank.
Thomas
[attachment=46964]