E-Mail aus excel an mehrere Empfänger

Sub lotus()
Dim sText As Variant, sEmpfang As String, sBetrifft As String
Dim session As Object, db As Object, doc As Object, rtobject, ws As Object
Dim i As Integer, y As Integer, Msg As Integer
Dim sKopie As String, AttachMe As Object, DerAnhang As Object
Dim user As String, server As String, mailfile As String, sBlindKopie As String
Dim vAn As Variant, vCopy As Variant, vBlind As Variant, sAnhang As String
On Error GoTo Fehler
sText = Range("B4") & vbCrLf ' Text aus Zelle (B4)
sText = Replace(sText, vbCrLf, Chr(10)) ' Zeilenumbrüche ändern
sEmpfang = Worksheets("Tabelle1").Range("I12" & x).Value
sBetrifft = Range("B3") 'Überschrift aus Zelle (b3)
'Wenn du keine Kopie od Blindkopie versenden willst, dann grad weglassen
sKopie = Range("D3") ' aus E-Mail-Adress in Zelle (D3)
'sBlindKopie = "Email1 ; Email2 " ' Einträge durch " ; " getrennt
vAn = Split(sEmpfang, " ; ") ' Empfänger Array
sAnhang = Range("B6") ' Muss natürlich richtig gesetzt werden
sAnhang2 = Range("B7")
sAnhang3 = Range("B8")
If Len(sKopie) > 0 Then vCopy = Split(sKopie, " ; ") 'cc Array
If Len(sBlindKopie) > 0 Then vBlind = Split(sBlindKopie, " ; ")  'bcc Array
Set session = CreateObject("notes.notessession") ' Notes muss gestartet sein
user = session.UserName
server = session.GetEnvironmentString("MailServer", True)
mailfile = session.GetEnvironmentString("MailFile", True)
Set db = session.getdatabase(server, mailfile)
Set doc = db.createdocument()
doc.Form = "Memo"
doc.SendTo = sEmpfang  ' an array
If Len(sKopie) > 0 Then doc.CopyTo = vCopy 'cc Array
If Len(sBlindKopie) > 0 Then doc.blindcopyto = vBlind 'bcc Array
doc.Subject = sBetrifft ' die Betreffzeile
doc.SAVEMESSAGEONSEND = True
doc.PostedDate = Now
'Die Zeilen mit dem Anhang nach hier oben verschieben, ist wichtig die Reihenfolge
If sAnhang  "" Then
Set AttachMe = doc.CREATERICHTEXTITEM("Attachment")
Set DerAnhang = AttachMe.EMBEDOBJECT(1454, "", sAnhang)
Set DerAnhang2 = AttachMe.EMBEDOBJECT(1454, "", sAnhang2)
Set DerAnhang3 = AttachMe.EMBEDOBJECT(1454, "", sAnhang3) ',"Attachment" wird nicht benö _
_
_
tigt
End If
Set ws = CreateObject("Notes.NotesUIWorkspace") ' **durch das öffnen des Dokumentes durch    _
_
_
NotesUIWorkspace**
Call ws.EDITDOCUMENT(True, doc)             ' **erreicht man das die eingestellte Signatur   _
_
_
aus den    **
Set doc = ws.CURRENTDOCUMENT                      ' **Lotus Notes Optionen eingefügt wird    _
_
_
Call doc.GOTOFIELD("Body")
Call doc.insertText(sText)
Call doc.Send(True)
Call doc.Close               'Schliesst das gesendete Formular
Call doc.Save(True, True)
Aufraeumen:
On Error Resume Next
Set AttachMe = Nothing
Set DerAnhang = Nothing
Set ws = Nothing
Set doc = Nothing
Set db = Nothing
Set session = Nothing
Exit Sub
Fehler:
Resume Aufraeumen
End Sub