Serienmail - generell CC - Empfänger ergänzen

Sub Excel_Serienmail_mit_mehreren_Anlagen_mit_Fehlermeldung_via_Outlook_Senden()
' von RAMSES  14.01.2003
'jeweils ab Zeile 2
'Spalte A = x oder leer  (x wenn email verschickt werden soll
'Spalte B = Empfängeremail-Adresse
'Spalte C = Betrefftext je Empfänger
'Spalte D = Mailtext je Empfänger
'Spalte E = nach Versand Eintrag von Datum/Uhrzeit NT-Username und Computername
'Spalte F = Leer
'Spalte G = Verzeichnis+Dateiname  (Max 10 Anlagen)
'Variablendefinition
Dim fs As Object, F As Object
Dim OutApp As Object, mail As Object
Dim i As Integer, y As Integer, Msg As Integer
Dim Nachricht As Variant
Dim AWS As String
Dim AnzEmpfänger As Integer
'Variablen füllen
'Filesystemobjekt erstellen
Set fs = CreateObject("Scripting.FileSystemObject")
'Hier die Anzahl Empfänger definieren
AnzEmpfänger = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'1. Fehlerprüfung
'Prüfen ob alle Inhalte vorhanden sind
'Wenn nicht wird das Makro abgebrochen
For i = 2 To AnzEmpfänger
If Cells(i, 2) = "" Then
Msg = MsgBox("Unvollständige Angaben beim Empfänger in Zeile " & i, vbCritical +  _
vbOKOnly, "Abbruch")
Exit Sub
End If
Next i
'2. Fehlerprüfung
'Mit dem FilesystemObjekt wird zuerst die Existenz der Dateien geprüft. '
'Wenn eine nicht existiert wird das Makro abgebrochen
'Die Links auf die Anlagen liegen im Bereich G2 : G11
For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
'Wenn eine Zelle leer ist, wird aus der Schleife ausgestiegen
'ohne weitere Fehlerprüfung
If Cells(y, 7) = "" Then Exit For
If fs.fileexists(Cells(y, 7)) = False Then
Msg = MsgBox("Die Datei: " & Cells(y, 7) & " in G" & y & " exitstiert nicht !" &  _
vbCrLf & "Der Sendevorgang an; " & Cells(i, 2) & " wird abgebrochen!", vbCritical + vbOKOnly, "Dateifehler")
Exit Sub
End If
Next y
'Sendevorgang einleiten
For i = 2 To AnzEmpfänger
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
On Error GoTo next_email
'Hier wird die zelle i in Spalte A auf den Wert X geprüft
'UCASE deshalb um Schreibfehler von Gross und klein zu vermeiden
If UCase(Cells(i, 1).Value) = "X" Then
'Trifft die Bedingung X zu wird der Mailversand eingeleitet
With Nachricht
.To = Cells(i, 2)       '"irgendwer@irgendein-provider.de"      SPALTE B
.Subject = Cells(i, 3)  '"Betreffzeile Header"                  SPALTE C
.Body = Cells(i, 4)     '"Sendetext"                            SPALTE D
'For y = 2 To 11
For y = 2 To ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
AWS = Cells(y, 7)
'Wenn die Zelle / Variable leer ist wird diese Schleife abgebrochen
If AWS = "" Then Exit For
.Attachments.Add AWS
Next y
'Hier wird die Mail zuerst angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
'Variablen zurücksetzen
Set OutApp = Nothing        'CreateObject("Outlook.Application")
Set Nachricht = Nothing     'OutApp.CreateItem(0)
Application.Wait (Now + TimeValue("0:00:01"))
'versanddatum /-uhrzeit /-userid und computername in spalte e eintragen
Worksheets(ActiveSheet.Name).Cells(i, 5).Value = Date & " / " & Time & _
" / " & Environ("username") & " " & Environ("computername")
next_email:
End If
'Bedingung abgeschlossen
Next i
End Sub