Option
Explicit
Sub
DatenHolen()
Dim
strPfad
As
String
Dim
strDatei
As
String
Dim
strExt
As
String
Dim
rngBereich
As
Range
Dim
lngTabMax
As
Long
Dim
lngTab
As
Long
Dim
lngZmax
As
Long
Dim
WB
As
Workbook
Dim
WS
As
Worksheet
Dim
wsAusgabe
As
Worksheet
On
Error
GoTo
Aufräumen
Set
wsAusgabe = ThisWorkbook.Worksheets(
"Tabelle1"
)
Dim
booAlleTabellen
As
Boolean
Dim
arrDaten
As
Variant
Dim
lngArrZmax
As
Long
Dim
lngArrSmax
As
Long
strPfad = "C:\temp\test\"
If
Right(strPfad, 1) <>
"\" Then strPfad = strPfad & "
\"
strExt =
"*.xls*"
Set
rngBereich = Range(
"A1:C20"
)
booAlleTabellen =
False
If
booAlleTabellen =
False
Then
lngTabMax = 1
Else
lngTabMax = WB.Worksheets.Count
End
If
strDatei = Dir(strPfad & strExt)
Do
While
Len(strDatei) > 0
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)
arrDaten = WS.Range(rngBereich.Address)
lngZmax = wsAusgabe.Cells(2 ^ 16, 1).
End
(xlUp).Row + 1
lngArrZmax = UBound(arrDaten, 1)
lngArrSmax = UBound(arrDaten, 2)
wsAusgabe.Range(wsAusgabe.Cells(lngZmax, 1), wsAusgabe.Cells(lngZmax + lngArrZmax - 1, lngArrSmax)) = arrDaten
Next
lngTab
WB.Close
False
End
If
strDatei = Dir()
Loop
Aufräumen:
On
Error
Resume
Next
WB.Close
False
On
Error
GoTo
0
Set
WB =
Nothing
Set
WS =
Nothing
Set
rngBereich =
Nothing
Set
wsAusgabe =
Nothing
End
Sub