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
On
Error
GoTo
Aufräumen
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
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
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
strDatei = Dir()
Loop
Aufräumen:
On
Error
Resume
Next
WB.Close
False
On
Error
GoTo
0
Set
WB =
Nothing
Set
WS =
Nothing
Set
wsAusgabe =
Nothing
End
Sub