Mailliste abarbeiten

Hallo liebe Gemeinde,
ich habe viel ähnliches gefunden aber irgendwie nicht das richtige.
Ich habe einen Code der Mails versendet für mich mit Anhang. Das Klappt soweit auch sehr gut. Aber jetzt habe ich eine Liste mit 180 Adressen an die jeweils eine Mail mit persönlichem Anhang gesendet werden soll.
Mein Code bisher:

Sub mailsenden()
Dim Outlook As Object
Dim OutlookMailItem As Object
Dim myAttachments As Object
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMailItem = OutlookApp.CreateItem(0)
Set myAttachments = OutlookMailItem.Attachments
With OutlookMailItem
.to = Range("C2")
'.cc =
.Subject = "Persönliche Agenda"
.Body = "Hallo " & Range("A2")
myAttachments.Add "C:\temp\" & Range("F2")
'.send
.Display
End With
Set OutlookApp = Nothing
Set OutlookMailItem = Nothing
End Sub

In Spalte C stehen alle Email Adressen, Spalte A die Namen und Spalte F die Dateinamen.
Jetzt möchte ich, dass die Makro die Liste von Zeile 1 bis 180 durcharbeitet und jeweils an die entsprechende Person den entsprechenden Anhang als Mail versendet.
Kann man mir da jemand helfen?
Vielen Dank und Grüße
Alex

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub mailsenden() Dim Outlook As Object Dim OutlookMailItem As Object Dim myAttachments As Object Dim rngZelle As Range Dim rngBereich As Range Dim wksBlatt As Worksheet Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1") 'Tabellennamen anpassen Set rngBereich = wksBlatt.Range("A1:A" & wksBlatt.Cells(wksBlatt.Rows.Count, 1).End(xlUp).Row) For Each rngZelle In rngBereich Set OutlookApp = CreateObject("outlook.application") Set OutlookMailItem = OutlookApp.CreateItem(0) Set myAttachments = OutlookMailItem.Attachments With OutlookMailItem .to = rngZelle '.cc = .Subject = "Persönliche Agenda" .Body = "Hallo " & rngZelle.Offset(0, 3) myAttachments.Add "C:\temp\" & rngZelle.Offset(0, 6) '.send .Display End With Set OutlookApp = Nothing Set OutlookMailItem = Nothing Next rngZelle End Sub

Sub mailsenden() Dim Outlook As Object Dim OutlookMailItem As Object Dim myAttachments As Object Dim rngZelle As Range Dim rngBereich As Range Dim wksBlatt As Worksheet Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1") 'Tabellennamen anpassen Set rngBereich = wksBlatt.Range("A1:A" & wksBlatt.Cells(wksBlatt.Rows.Count, 1).End(xlUp).Row) For Each rngZelle In rngBereich Set OutlookApp = CreateObject("outlook.application") Set OutlookMailItem = OutlookApp.CreateItem(0) Set myAttachments = OutlookMailItem.Attachments With OutlookMailItem .to = rngZelle.Offset(0, 3) '.cc = .Subject = "Persönliche Agenda" .Body = "Hallo " & rngZelle myAttachments.Add "C:\temp\" & rngZelle.Offset(0, 6) '.send .Display End With Set OutlookApp = Nothing Set OutlookMailItem = Nothing Next rngZelle End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread