Nur bestimmte Zeilen kopieren

Sub Sammeln1()
Dim FName$, FCount%, R%, c%, nC, i&
Dim Bereich As Range
Dim FileArray()
Dim ProcessCounter As Integer
Application.ScreenUpdating = False
ChDrive "c"
ChDir "C:\Users\slidex\Desktop\Statistiken\Statistiken_neu\KW1"
FName = Dir("*.xls")
Do While FName  ""
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop
i = 1
For ProcessCounter = 1 To FCount
Application.DisplayAlerts = False
Workbooks.Open FileArray(ProcessCounter)
On Error Resume Next
R = Cells.Find("*", [A1], , , xlByRows, _
xlPrevious).Row
c = Cells.Find("*", [A1], , , _
xlByColumns, xlPrevious).Column
If Err = 91 Then GoTo WEITER1
Set Bereich = ActiveWorkbook.Worksheets(1) _
.Range(Cells(1, 1), Cells(R, c))
Bereich.Copy Tabelle1.Cells(i, 1)
i = i + R + 1
On Error GoTo 0
WEITER1:
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next ProcessCounter
End Sub