durch Eure Hilfe klappt das gruppieren der Mailadressen und der Versand wunderbar.
Vielen Dank nochmal an alle die hier unterstützt haben.
Alter Thread: https://www.herber.de/forum/archiv/1904to1908/1905695_Mail_VBA_Mailadressen_gruppieren.html
Nun soll eine Mail (je gleicher Nummer in Spalte 9) mit dem fast gleichen Inhalt an den Empfänger in der Spalte 11 + einer Excel als Anhang mit den Namen Spalte 10
(Werte ab A10 untereinander) angehängt werden.
Beispiel:
empfänger1@xy.com soll eine Mail erhalten + Excel Datei und Namen Hans M. + + Holger K.
empfänger2@xy.com soll eine Mail erhalten + Excel Datei mit einer Excel und Namen Andreas L. + Jürgen H.
empfänger3@xy.com soll eine Mail erhalten mit einer Excel und Namen Andrea A.. + Uwe Z. + Lukas I.
Ich hoffe das war verständlich beschrieben.
Ansonsten kann sich das wie folgt vorstellen:
Mit dem u.g. Coding wurden Teilnehmer einer Veranstaltung informiert.
Jetzt soll bestimmte Person eine Liste der mit den Teilnehmern erhalten.
Hier das Coding zum gruppierten Mailversand.
Sub Mailversand()
Dim i As Integer
Dim oApp As Object
Dim lbody As String
Dim strVorlage As String
Dim objTO As Object, oOBJ
Set objTO = CreateObject("scripting.dictionary")
Range("A1").Select
For i = 8 To Cells(9999, 1).End(xlUp).Row
objTO(Cells(i, 9).Value) = objTO(Cells(i, 9).Value) & ";" & Cells(i, 5)
Next i
For Each oOBJ In objTO
i = Application.Match(oOBJ, Columns(9), 0)
Set oApp = CreateObject("Outlook.Application")
'Wechseln der Mailvorlage
If Cells(i, 21) = "XX" Then strVorlage = "XX.oft" Else strVorlage = "XY.oft"
Set myitem = oApp.CreateItemFromTemplate(strVorlage)
With myitem
Set .SendUsingAccount = oApp.Session.Accounts.Item("absender@xy.com")
'mail an
lto = Mid(objTO(oOBJ), 2) ' Cells(i, 5).Value
'Betreffzeile
lsubject = Cells(i, 2).Value
lsubject = lsubject + " - " & Cells(i, 14).Value
lsubject = lsubject + " - " & Cells(i, 15).Value
'Bodytext
lbody = myitem.HTMLBody
lbody = Replace(lbody, "#2#", Cells(i, 2).Value)
lbody = Replace(lbody, "#14#", Cells(i, 14).Value)
lbody = Replace(lbody, "#15#", Cells(i, 15).Value)
lbody = Replace(lbody, "#17#", Cells(i, 17).Value)
lbody = Replace(lbody, "#18#", Cells(i, 18).Value)
lbody = Replace(lbody, "#19#", Cells(i, 19).Value)
lbody = Replace(lbody, "#20#", Replace(Cells(i, 20).Value, Chr(10), ""))
myitem.To = lto
myitem.cc = lcc
myitem.bcc = lbcc
myitem.Subject = lsubject
myitem.HTMLBody = lbody
myitem.Display
myitem.send
End With
Next oOBJ
End Sub