VBA Email versenden

Sub Schritt2_Emails_senden()
Dim Address As Variant
Dim Dict As Object
Dim DstWkb As Workbook
Dim EmailInfo As Variant
Dim Filename As String
Dim i As Long, j As Long
Dim NewWkb As Workbook
Dim olApp As Object
Dim rng As Range
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet
Dim SheetName As String
Dim SheetNames As Variant
Dim SubjectLine As String
Dim MsgBody As String
Dim LastRow As String
Dim MName As String
Dim mySheetName As String
LastRow = Sheets("Contacts").Cells(Rows.Count, 1).End(xlUp).Row
SubjectLine = "Testlauf"
MsgBody = "TEST"
Set rng = Range("A1").CurrentRegion
' EmailInfo starts in column "B" to the last column used.
Set EmailInfo = Intersect(rng, rng.Offset(1, 0))
' Copy the sheet names and email addresses into arrays for faster processing.
SheetNames = EmailInfo.Columns(1).Cells.Value
EmailInfo = Intersect(EmailInfo, EmailInfo.Offset(0, 1)).Value
' Create an associative array to hold the email addresses and the sheet names for  _
each one.
Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare
' Collect email addresses and sheet names associated with each address.
For i = 1 To UBound(EmailInfo, 1)
For j = 1 To UBound(EmailInfo, 2)
SheetName = SheetNames(i, 1)
Address = EmailInfo(i, j)
If Address  "" Then
If Not Dict.Exists(Address) Then
Dict.Add Address, SheetName
Else
SheetName = Dict(Address) & "," & SheetName
Dict(Address) = SheetName
End If
End If
Next j
Next i
' Open the workbook with the sheets to be copied as email attachments.
Set SrcWkb = ActiveWorkbook
Set olApp = CreateObject("Outlook.Application")
If Sheets(1).CheckBox1.Value = True Then
For Each Address In Dict.Keys
' Create a new workbook to be used as the attachment.
Set DstWkb = Workbooks.Add(xlWBATWorksheet)
' Copy all the sheets associated with an email to the new workbook.
SheetNames = Split(Dict(Address), ",")
For i = 0 To UBound(SheetNames, 1)
SrcWkb.Worksheets(SheetNames(i)).Copy After:=DstWkb. _
Worksheets(DstWkb.Worksheets.Count)
ActiveSheet.Name = SheetNames(i)
mySheetName = "Tabelle1"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(mySheetName).Delete
With ActiveSheet
.Cells.Copy
.Cells.PasteSpecial Paste:=xlValues
.Columns("H:H").Select
Selection.NumberFormat = "dd/mm/yyyy"
Range("A1:B1").Select
Selection.Cut Destination:=Range("B1:C1")
Range("A3").Select
Selection.Cut Destination:=Range("E1")
Range("A4").Select
Selection.Cut Destination:=Range("F1")
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Rows("3:3").Select
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
End With
Next i
' Save the new workbook in the User's Temp folder.
MName = ActiveSheet.Name & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Environ("TEMP") & "\" &  _
MName
Application.DisplayAlerts = True
With olApp.CreateItem(0)
.To = Address
.Subject = SubjectLine
.Body = MsgBody
.Attachments.Add DstWkb.FullName, 1, 1
.Display 'send
End With
' Close the new workbook and delete it from the Temp folder.
DstWkb.Close SaveChanges:=False
On Error Resume Next
Kill ThisWorkbook.Path & "\" & ThisWorkbook.Name
Next Address
ElseIf Sheets(1).CheckBox1.Value = False Then
'Das gleiche wie oben, statt .display, .send
End If
End Sub