VBA Programmierung automatischer Email Versandt

[fatih1995]

Hallo ich hoffe Ihr könnt mir helfen :/

Folgendes Problem: Wenn ich die Mail versende, öffnen sich für jede Zeile eine extra Email und leider auch nur jeweils ein Empfänger und einer in cc.

Was muss ich nun in der Programmierung hinzufügen, um nur eine Email geöffnet zu bekommen, mit mehreren Empfängern (Falls mehrere Kreuze gesetzt worden sind). Ich danke euch echt wenn Ihr mir helfen können :/

Ich habe mir die Bausteine aus dem Internet zusammengesetzt, bin daher kein Profi darin.

Programmtext:

Private Sub Send_Email()

   '-------------< Send_Email() >-------------

   Dim sTitle As String

   sTitle = "Test-HTML Email from Excel"

   '< HMTL holen >

   Dim sTemplate As String

   sTemplate = Sheets("ini_Vorlage").Shapes(1).TextFrame2.TextRange.Text

   '</ HMTL holen >

   '----< Send with Outlook >----

   Dim app_Outlook As Outlook.Application

   Set app_Outlook = New Outlook.Application

   '--< Email einstellen >--

   Dim objEmail As Outlook.MailItem

   Dim sEmail_Addresscc As String

   Dim sEmail_Address As String

   Dim iRow As Integer

   For iRow = 4 To 100

       If Cells(iRow, 21) = "x" Then

           '< get Email Address >

           'Column 2, B

           sEmail_Address = Cells(iRow, 19)

           sEmail_Addresscc = Cells(iRow, 20)

           '</ get Email Address >

           '< Fill Placeholders >

           Dim sHTML As String

           sHTML = Replace(sTemplate, "[@Name]", sEmail_Address)

           '</ Fill Placeholders >

           '--< Send Email >--

           Set objEmail = app_Outlook.CreateItem(olMailItem)

           objEmail.To = sEmail_Address

           objEmail.CC = sEmail_Addresscc

           objEmail.Subject = sTitle

           'objEmail.HTMLBody = sHTML 'use .HTMLBody for HTML

           objEmail.Body = sHTML      'and .body for pure Text

           objEmail.Display

           '--</ Send Email >--

       End If

   Next

   '< Abschluss >

   Set objEmail = Nothing

   Set app_Outlook = Nothing

   '</ Abschluss >

   MsgBox "Emails erstellt", vbInformation, "Fertig"

   '----</ Send with Outlook >----

   '-------------</ Send_Email() >-------------

End Sub