E-Mail aus Tabelle - gleiche Empfänger zusammenfas
24.07.2019 13:53:40
Harald
Ich hoffe jemand kann mir bei folgenden Problem weiterhelfen.
Ich habe ein Makro, welches E-Mails aus einer Tabelle ausliest und versendet.
Dieses Makro habe ich zum Teil hier aus dem Forum übernommen und funktioniert auch prima.
Die E-Mail-Adressen werden aus der Spalte Q ausgelesen. Dann werden E-Mails mit den Daten aus Spalte A bis C erstellt.
Angenommen ein Empfänger steht 10x in Spalte Q, dann bekommt dieser Empfänger 10 E-Mails.
Dies möchte ich nun verhindern.
Wenn ein Empfänger mehr als einmal vorkommt, dann soll dieser nur 1 E-Mail bekommen, aber darin sollen die jeweiligen Daten aus Spalte A bis C aufgelistet werden.
Hat jemand vielleicht eine Idee, wie ich einstellen kann, dass die Daten pro Empfänger zusammengefasst werden?
Vielen Dank im Voraus!
LG
Harald
Derzeitiges Makro:
Sub Mails_erstellen()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim OutlookOpened As Boolean
OutlookOpened = False
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
OutlookOpened = True
End If
On Error GoTo 0
Sheets("Abfrage").Select
For Each cell In Columns("Q").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "abc@def.ghi"
.To = Cells(cell.Row, "Q").Value
.Subject = "test"
.htmlbody = "Sehr geehrte Damen und Herren," & "" & _
"Ihre Daten ..." & "
" & _
Cells(cell.Row, "A").Value & " " & Cells(cell.Row, "B").Value & " " & Cells( _
cell.Row, "C").Value
'hier werden die Daten derzeit nur aus einer Zeile übernommen
.display
End With
End If
Next cell
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
MsgBox "Mails wurden erstellt"
End Sub