Sub
verteilen()
Dim
sh
As
Worksheet
Dim
i&, maxrow&, rng
As
Range
Dim
praefix$
Const
TEILER = 50000
praefix = Application.InputBox(
"Vorsilbe eingeben"
,
"Eingabe"
, Type:=2)
If
praefix =
""
Or
praefix =
"Falsch"
Then
MsgBox
"Keine Vorsilbe für Dateinamen ausgewählt"
, vbCritical + vbOKOnly,
"Abbruch"
Exit
Sub
End
If
Set
sh = ActiveSheet
Set
rng = Intersect(sh.UsedRange, sh.Rows(1))
maxrow = sh.UsedRange.Rows.Count
Application.ScreenUpdating =
False
Application.DisplayAlerts =
False
For
i = 2
To
maxrow
With
Worksheets.Add(after:=Worksheets(Worksheets.Count))
.Name = praefix & i - 1 &
" - "
& i - 2 + TEILER
rng.Copy .Cells(1, 1)
sh.Cells(i, 1).Resize(TEILER, rng.Columns.Count).Copy .Cells(2, 1)
Application.CutCopyMode =
False
.Copy
ActiveWorkbook.SaveAs Filename:=.Parent.Path & "\" & .Name
ActiveWorkbook.Close
i = i + TEILER - 1
.parent.Activate
If
i > maxrow
Then
Exit
Sub
End
With
Next
Application.ScreenUpdating =
True
Application.DisplayAlerts =
True
End
Sub