Option Explicit
Dim oShS As Excel.Worksheet
Dim oWbk As Excel.Workbook
Dim oShT As Excel.Worksheet
Sub SoSo()
Dim x As Long, y As Long, z As Long
Dim rngS As Range
Const C_Sourc As String = "Export"
Const C_First As String = "B2"
Const C_LastC As String = "BE"
Const C_Step As Long = 100
Const C_Pfad As String = "E:\VBA\Test.xlsx"
Const C_Targ As String = "Übersicht"
Const C_Cell As String = "B2"
Const C_NewN As String = "E:\VBA\Fertig_Datei_XYZ.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error GoTo JErr
Set oShS = ThisWorkbook.Worksheets(C_Sourc)
With oShS
z = .Cells.Find("*", .Cells(1), -4123, 2, 1, 2, False).Row
Set rngS = Range(.Range(C_First), .Columns(C_LastC).Cells(z))
End With
For x = 1 To z Step C_Step
Set oWbk = Workbooks.Open(C_Pfad)
Set oShT = oWbk.Worksheets(C_Targ)
rngS.Rows(x).Resize(C_Step).Copy
oShT.Range(C_Cell).PasteSpecial (xlPasteValues)
y = y + 1
oWbk.SaveAs _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False, _
Filename:=Replace(C_NewN, "XYZ", Format(y, "0"))
oWbk.Close False
Set oWbk = Nothing
Next x
On Error GoTo 0
JErr:
If Err.Number > 0 Then
If Not oWbk Is Nothing Then
On Error Resume Next
oWbk.Close False
Set oWbk = Nothing
End If
Call MsgBox("prüfe die Makrovorgaben", vbExclamation, "Fehler aufgetreten")
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set oShS = Nothing
End Sub