Option Explicit
Sub DatenHolen()
Dim strPfad As String
Dim strDatei As String
Dim strExt As String
Dim lngTabMax As Long
Dim lngTab As Long
Dim lngZmax As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim wsAusgabe As Worksheet
Set wsAusgabe = ThisWorkbook.Worksheets("Tabelle1")
Dim booAlleTabellen As Boolean
Dim arrBereich As Variant
Dim arrBereichIndex As Long
Dim arrDaten As Variant
Dim lngArrZmax As Long
Dim lngArrSmax As Long
Dim datLetztesDatum As Date
Dim datDatei As Date
datLetztesDatum = wsAusgabe.Range("LetztesDatum")
strPfad = "C:\temp\test\"
If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
strExt = "*.xls*"
arrBereich = Array("G2", "B6", "B8", "B9", "H8", "M9")
booAlleTabellen = False
If booAlleTabellen = False Then
lngTabMax = 1
Else
lngTabMax = WB.Worksheets.Count
End If
strDatei = Dir(strPfad & strExt)
Do While Len(strDatei) > 0
datDatei = FileDateTime(strPfad & strDatei)
If datLetztesDatum < datDatei Then
Set WB = Workbooks.Open(Filename:=strPfad & strDatei, ReadOnly:=True)
If Not WB Is Nothing Then
For lngTab = 1 To lngTabMax
Set WS = WB.Worksheets(lngTab)
ReDim arrDaten(UBound(arrBereich))
For arrBereichIndex = LBound(arrBereich) To UBound(arrBereich)
arrDaten(arrBereichIndex) = WS.Range(arrBereich(arrBereichIndex)).Value2
Next arrBereichIndex
lngZmax = wsAusgabe.Cells(2 ^ 16, 1).End(xlUp).Row + 1
wsAusgabe.Range(wsAusgabe.Cells(lngZmax, 1), wsAusgabe.Cells(lngZmax, UBound(arrDaten) + 1)) = arrDaten
Next lngTab
WB.Close False
End If
End If
strDatei = Dir()
Loop
Aufräumen:
On Error Resume Next
WB.Close False
On Error GoTo 0
wsAusgabe.Range("LetztesDatum") = Format(Now(), "dd.mm.yyyy")
Set WS = Nothing
Set WB = Nothing
Set wsAusgabe = Nothing
End Sub