janzieglerschulz
Goto Top

Mails via VBA Makro aus Excel mit Anhang versenden - an verschiedene Empfänger, aber pro Empfänger nur max. eine Mail

Hallo zusammen,

hoffe es kann mir jemand bei folgendem Problem helfen. Ich hänge hier nun schon seit Tagen fest und komme einfach nicht weiter...

Mit diesem Makro sollen Mails mit einer Excel Datei im Anhang versendet werden. Der Inhalt des Anhangs soll ein separates Tabellenblatt sein, in welches die Werte aus dem "Master"-Tabellenblatt kopiert werden, wenn folgende Bedingungen erfüllt sind:

1. Inhalte einer Zeile werden nur dann kopiert, wenn in Spalte W ein "versenden" steht
2. Es sollen, wenn diese Bedingung zutrifft, nur die Spalten A bis M sowie die Spalte R kopiert werden.
3. In Spalte P steht die Empfänger-Mailadresse


Weiter unten sollen die Mails dann noch nach "Mailadresse" (Spalte P) zusammengefasst, sodass pro Mailadresse nur eine Mail rausgeht. Dies funktioniert leider nicht. Kann mir jemand sagen wieso?

Folgend der Code.

Sub Makro3()
'
' Makro3 Makro
'
' Tastenkombination: Strg+k

If MsgBox("Sollen die Anschreiben 'Kontraktkorrektur' nun versendet werden?", vbYesNo) <> vbYes Then Exit Sub


Dim ws As Worksheet, rngSource As Range, dic As Object, c As Range, firstAddress As String, cell As Range
'Dictionary Objekt erzeugen indem wir die bereits bearbeiteten Zeilen hinterlegen
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String

'Werte in <Kontraktkorrektur> kopieren, wenn <versenden> in Spalte W

Sheets("Kontraktkorrektur").UsedRange.Clear

With Sheets("MASTER")
.AutoFilterMode = False
.Columns("W:W").AutoFilter Field:=1, Criteria1:="=versenden", Operator:=xlAnd
.Range(Replace("A1:O#,Q1:Q#", "#", .UsedRange.Rows.Count)).Copy Sheets("Kontraktkorrektur").Range("A1")
.AutoFilterMode = False

End With

With Sheets("Kontraktkorrektur")
.Rows("1:1").AutoFilter
.Cells.EntireColumn.AutoFit
End With


SavePath = "H:\VKK" '"E:\Eigene Dateien"
'Kopiert Sheet "überfüllte_Behälter" in eine neue Mappe
'welche nur diese Tabelle enthält
Sheets("Kontraktkorrektur").Copy
'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & "_" & Format(Now, "ddmmyyyy_hhmm") & ".xlsx"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With


Set dic = CreateObject("Scripting.Dictionary")
'Outlook-Objekt erzeugen
Set objOL = CreateObject("Outlook.Application")
'Tabellenblatt referenzieren
Set ws = Worksheets("MASTER")

'belegter Range der Zeilen ermnitteln
Set rngSource = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp))

'Für jede Zeile im Range
For Each cell In rngSource
' wenn die Zeile noch nicht bearbeitet wurde und in Spalte W eine "versenden" steht (22 = Spalte W)
If Not dic.Exists(cell.Row) And cell.Offset(0, 22).Value = "versenden" Then
Dim strMailBody
'Mail erzeugen
Set objMail = objOL.CreateItem(0)
'Eigenschaften der Mail zuweisen
objMail.SentOnBehalfOfName = "vkk@wuerth-industrie.com"
objMail.Subject = "Kontraktkorrektur"
objMail.To = cell.Offset(0, 15).Value
objMail.Body = "Liebe Kolleginnen und Kollegen," _
& vbNewLine & vbNewLine & _
"nachfolgend sind alle Kontrakte aufgelistet deren Einteilungen in der Vergangenheit liegen." _
& vbNewLine & _
"Bitte prüfen und entsprechend aktualisiern. Sollten die Einteilungen nicht innerhalb einer Woche aktualisiert worden sein, werden wir dies entsprechend durchführen." _
& vbNewLine & vbNewLine & _
"Bei Fragen oder Problemen können Sie sich jederzeit an mich wenden." _
& vbNewLine & vbNewLine & _
"Termin: eine Woche nach Versanddatum" _
& vbNewLine & vbNewLine & _
"Viele Grüße" _
& vbNewLine & _
"VKK"
'Mailbody erzeugen aber noch nicht endgültig der Mail zuweisen
'strMailBody = cell.Offset(0, 16) & vbNewLine & vbNewLine & cell.Offset(0, 17).Value & vbNewLine

'In Spalte "Mail" nach dem aktuellen Zellwert in Spalte Mail suchen
With rngSource.Offset(cell.Row, 15)
Set c = .Find(cell.Offset(0, 15).Value, LookIn:=xlValues, lookAt:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
' Nur wenn in Spalte V "versenden" steht
If ws.Cells(c.Row, 22).Value = "versenden" Then
'bearbeitete Zeile zum Dictionary hinzufügen, so dass sie später nicht nochmal verwendet wird
If Not dic.Exists(c.Row) Then dic.Add c.Row, ""
'dem Mailbody den Inhalt von Spalte Z hinzufügen
'strMailBody = strMailBody & c.Offset(0, -2) & vbNewLine
'nächste Fundstelle suchen
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress


End If


End With


'Mailbody der Mail zuweisen
'objMail.Body = _
'"Liebe Kolleginnen und Kollegen," _
'& vbNewLine & vbNewLine & _
'"nachfolgend sind alle Kontrakte aufgelistet deren Einteilungen in der Vergangenheit liegen." _
'& vbNewLine & _
'"Bitte prüfen und entsprechend aktualisiern. Sollten die Einteilungen nicht innerhalb einer Woche aktualisiert worden sein, werden wir dies entsprechend durchführen." _
'& vbNewLine & vbNewLine & _
'"Bei Fragen oder Problemen können Sie sich jederzeit an mich wenden." _
'& vbNewLine & vbNewLine & _
'"Termin: eine Woche nach Versanddatum" _
'& vbNewLine & vbNewLine & _
'"Viele Grüße" _
'& vbNewLine & _
'"VKK" _


'strMailBody _
'& vbNewLine & _


'Mail zum testen nur anzeigen
objMail.Display
'Mail direkt in Postausgang legen, ohne anzeigen!
objMail.Attachments.Add AWS
'objMail.Send


End If

Next

ActiveWorkbook.Save

Kill AWS
'MsgBox "Anschreiben erfolgreich an Outlook übertragen!"

'Call Mail_an_VKK
'Call Zeilen_entfernen

If Sheets("Kontraktkorrektur").FilterMode Then Sheets("Kontraktkorrektur").ShowAllData
Sheets("Kontraktkorrektur").Cells.Clear
If Sheets("aktuelle Kontrakte").FilterMode Then Sheets("aktuelle Kontrakte").ShowAllData
Sheets("aktuelle Kontrakte").Range("A2:P50000").Clear
Sheets("aktuelle Kontrakte").Range("Q3:Q50000").Clear
Sheets("aktuelle Kontrakte").Range("R3:R50000").Clear
Worksheets("MASTER").Rows("1:1").AutoFilter


End Sub


Vielen Dank vorab und Grüße
Jan

Content-Key: 305173

Url: https://administrator.de/contentid/305173

Ausgedruckt am: 19.03.2024 um 03:03 Uhr