Sortieren, alles in eine Arbeitsmappe und senden

'########################################################################################################################
'
'Versenden
'
'########################################################################################################################

Public Sub Versenden()
Dim aktuelleZeile As Long
Dim LetzerStandort As String
Dim start As Long
Dim ende As Long
Sheets("Auswertung_sortiert").Activate
aktuelleZeile = 1
letzterStandort = ActiveSheet.Cells(2, 1).Value
aktuellerStandort = ActiveSheet.Cells(2, 1).Value
start = 2
While ActiveSheet.Cells(aktuelleZeile, 1).Value  ""
aktuelleZeile = aktuelleZeile + 1
aktuellerStandort = ActiveSheet.Cells(aktuelleZeile, 1).Value
If letzterStandort  aktuellerStandort And aktuelleZeile  2 Then
ende = aktuelleZeile - 1
kopiereStandordaten start, ende
start = aktuelleZeile
letzterStandort = aktuellerStandort
End If
Wend
End Sub

'########################################################################################################################
'
'kopiereStandordaten
'
'########################################################################################################################

Public Sub kopiereStandordaten(start As Long, ende As Long)
ActiveSheet.Range(Cells(start, 1), Cells(ende, 6)).Select
Selection.Copy
Sheets("Versandvorlage").Select
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F1").Value = Now
versenden_Arbeitsmappe
ActiveSheet.Range("A10:F500").Select
Selection.Clear
End Sub

'########################################################################################################################
'
'Function FileExist
'
'########################################################################################################################
Function FileExist(ByVal strPath As String) As Boolean
FileExist = Len(Dir$(strPath)) 0
End Function

'########################################################################################################################
'
'kopieren_arbeitsmappe
'
'########################################################################################################################

Public Sub kopieren_arbeitsmappe(druckbereich As String)
On Error GoTo ErrorHandler
Dim WB_Ziel As String
Dim WB_Quelle As String
WB_Quelle = ActiveWorkbook.Name
Workbooks.Add
WB_Ziel = ActiveWorkbook.Name
Windows(WB_Ziel).Activate
Windows(WB_Quelle).Activate
Cells.Select
Selection.Copy
Windows(WB_Ziel).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:= _
False
Windows(WB_Quelle).Activate
Application.CutCopyMode = False
Selection.Copy
Windows(WB_Ziel).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=  _
_
False
Application.CutCopyMode = False
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False
'With ActiveWorkbook
'    '.PrecisionAsDisplayed = False
'    .Date1904 = True
'End With
With ActiveSheet.PageSetup
.Zoom = False
.PrintArea = druckbereich
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Cells(1, 1).Select
Exit Sub
ErrorHandler:
Cells(1, 1).Select
MsgBox Err.Description, vbCritical
End Sub

'########################################################################################################################
'
'versenden_Arbeitsmappe
'
'########################################################################################################################

Private Sub versenden_Arbeitsmappe()
Dim empfn As String
Dim i As Integer
Dim betr As String
Dim dateiname_kurz As String
Dim dateiname_lang As String
On Error GoTo e_handler
empfn = Range("B7").Value
betr = "Telefonreporting " & Range("B1").Value & " " & Range("B6").Value & ", " & Range("d1" _
_
).Value
dateiname_kurz = "Telefonreporting_" & "_" & Range("B6").Value & "_"
kopieren_arbeitsmappe "A1:BS200"
dateiname_lang = ThisWorkbook.SaveFileAS(dateiname_kurz)
ActiveWorkbook.SendMail empfn, betr
ActiveWorkbook.Close False
If FileExist(dateiname_lang) Then Kill dateiname_lang
Exit Sub
e_handler:
MsgBox "Fehler beim Versenden der Arbeitsmappe: " & Err.Description
ActiveWorkbook.Close False
If FileExist(dateiname_lang) Then Kill dateiname_lang
End Sub

Mein Problem besteht jetzt darin das das Script nur automatisch eine Email verschickt.
Es sollte allerdings nach der ersten Mail eine nächste neue Mappe generieren und die 2 Mail
rausschicken usw.Das Problem ist in

Public Sub Versenden() bei aktueller Zeile sofern ich mich
nicht irre.
Hat jemand ne vielleicht ne idee?