AW: Mit den Angaben leider nicht...
16.08.2018 17:05:36
Japhi
Hallo Werner,
vielen Dank für die Antwort. Hier das Makro:
Option Explicit
Const strSheetQ As String = "Consolidated" ' DIE Tabelle wird ausgelesen"
Const strSheetZ As String = "Total" ' Die Tabelle in DIESER Datei
Const strRange As String = "A2:K1231" ' Der Bereich wird ausgelesen
Public Sub Files_Read()
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")
' Datei im gleichen Ordner wie Auswertungsdateien
' strDir = ThisWorkbook.Path & "\"
' Fester Ordner vorgegeben
strDir = "C:\Test\"
strDir = IIf(Right(strDir, 1) "\", strDir & "\", strDir)
Set objDir = objFSO.GetFolder(strDir)
With ThisWorkbook.Worksheets(strSheetZ)
Worksheets("Total").Range("A2:K500000").Clear
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*" ' Ohne Unterordner
.UsedRange.Value = .UsedRange.Value
End With
Fin:
With Application
.Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
.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
Dim strTMP As String
strTMP = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name _
ThisWorkbook.Name And Left(varTMP.Name, 1) "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Range(.Cells(lngLastRow, 1), _
.Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
Range(strRange).Columns.Count))
.FormulaArray = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
End With
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub