Makro Bereich kopieren und in neue Datei einfügen

Sub Gruppe_speichern()
'Werte nach Gruppen aufteilen und in gesonderten Dateien sichern
'Die Werte aus den Spalten A:P sollen je Gruppe in gesonderten Arbeitsmappen
'in dem in Zelle G1 genannten Verzeichnis gespeichert werden.
' Inizialisierung
Dim rng As Range
Dim col As New Collection
Dim iRow As Integer
Dim bruch As Integer
Dim sFile As String
Dim Datei As String
Dim Zähler As Integer
Application.ScreenUpdating = False
'Startpunkt festlegen
iRow = 1
'Sicherungspfad holen
sFile = Range("G1").Value
On Error Resume Next
Zähler = 0
'Lesen der einzelnen Gruppen
Do Until IsEmpty(Cells(iRow, 1))
col.Add Cells(iRow, 1).Value, Cells(iRow, 1).Text
iRow = iRow + 1
Loop
On Error GoTo 0
Application.DisplayAlerts = False
For iRow = 2 To col.Count
Zähler = Zähler + 1
'Selection mittels autofilter der einzelnen Gruppen
Range("A1").CurrentRegion.AutoFilter field:=1, Criteria1:=col(iRow)
Set rng = Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible)
rng.Copy
'Speicher der ausgewählten Zeilen
Application.ScreenUpdating = True
Workbooks.Add
'Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=  _
_
False, Transpose:=False
ActiveSheet.Cells(2, 1).Select
Application.ScreenUpdating = False
Datei = ActiveSheet.Cells(2, 1).Value
'speichern der Daten in eine Exceldatei
ActiveWorkbook.SaveAs Filename:=sFile & Datei & ".xls"
Application.StatusBar = "Insgesamt:  " & Zähler & "  Dateien  " & _
" Datei wurde gespeichert als: " & ActiveWorkbook.Name
ActiveWorkbook.Close savechanges:=True
'nächste Gruppe
Next iRow
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.AutoFilterMode = False
Application.StatusBar = ""
MsgBox "Die Datei wurde aufgeteilt in " & Zähler & " Dateien und gesichert", vbExclamation
End Sub