VBA Makro Mails aus Excel versenden
Guten Tag zusammen,
folgendes Problem treibt mich schon seit Tagen zur Verzweiflung:
Aus einer Excel Datei werden durch folgendes Makro automatische Mails generiert.
Dies klappt soweit auch ohne Probleme. Allerdings soll folgendes mit eingebaut werden:
Für jede Zeile wird aktuell eine Mail generiert.
Allerdings sollen Zeilen in einer Mail zusammengeführt werden, wenn der Inhalt aus Spalte Y in den Zeilen gleich ist.
Der Mailtext soll zudem eine Zusammenfassung der betroffenen Zeilen aus Spalte Z darstellen
Gibt es hierzu eine mögliche Lösung?
Ich bin dankbar für jeden Tipp, der mich der Lösung näher bringt!
*
Sub Excel_Serial_Mail()
LetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long
'Start der Sendeschleife an alle Empfänger bis letzte gefüllte Zeile erreicht ist.
For i = 1 To LetzteZeile
If (i / 2) = Int(i / 2) Then
If Cells(i, 3) = 1 Then
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Die Empfänger stehen in Spalte B ab Zeile 1
'.To = Cells(i, 2) 'E-Mail Adresse
'Der Betreff in Spalte A
.Subject = Cells(i, 1) '"Betreffzeil"
'Der zu sendende Text in Spalte C
'Der Text wird ohne Formatierung übernommen
.Body = Cells(i, 2)
'Hier wird die Mail angezeigt
.Display
End With
'Objectvariablen leeren
Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
'Sendepause einschalten
Application.Wait (Now + TimeValue("0:00:01"))
End If
End If
Next i
End Sub
*
folgendes Problem treibt mich schon seit Tagen zur Verzweiflung:
Aus einer Excel Datei werden durch folgendes Makro automatische Mails generiert.
Dies klappt soweit auch ohne Probleme. Allerdings soll folgendes mit eingebaut werden:
Für jede Zeile wird aktuell eine Mail generiert.
Allerdings sollen Zeilen in einer Mail zusammengeführt werden, wenn der Inhalt aus Spalte Y in den Zeilen gleich ist.
Der Mailtext soll zudem eine Zusammenfassung der betroffenen Zeilen aus Spalte Z darstellen
Gibt es hierzu eine mögliche Lösung?
Ich bin dankbar für jeden Tipp, der mich der Lösung näher bringt!
*
Sub Excel_Serial_Mail()
LetzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long
'Start der Sendeschleife an alle Empfänger bis letzte gefüllte Zeile erreicht ist.
For i = 1 To LetzteZeile
If (i / 2) = Int(i / 2) Then
If Cells(i, 3) = 1 Then
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Die Empfänger stehen in Spalte B ab Zeile 1
'.To = Cells(i, 2) 'E-Mail Adresse
'Der Betreff in Spalte A
.Subject = Cells(i, 1) '"Betreffzeil"
'Der zu sendende Text in Spalte C
'Der Text wird ohne Formatierung übernommen
.Body = Cells(i, 2)
'Hier wird die Mail angezeigt
.Display
End With
'Objectvariablen leeren
Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
'Sendepause einschalten
Application.Wait (Now + TimeValue("0:00:01"))
End If
End If
Next i
End Sub
*
Kommentieren
Teilen
Auf Facebook teilen
Auf X (Twitter) teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 247434
Url: https://administrator.de/forum/vba-makro-mails-aus-excel-versenden-247434.html
Ausgedruckt am: 28.05.2025 um 21:05 Uhr
7 Kommentare
Neuester Kommentar
Hallo ExxiSt, Willkommen auf Administrator.de!
Ich habe dir hier mal ein Demo-Sheet zusammengestellt, das das gewünschte macht, soweit ich deine Schilderung richtig interpretiert habe. Damit solltest du dein Vorhaben realisieren können. Weitere Kommentare befinden sich im Quellcode.
Grüße Uwe
p.s. Bitte nutze in Zukunft Code-Tags für deinen Quellcode:
Ich habe dir hier mal ein Demo-Sheet zusammengestellt, das das gewünschte macht, soweit ich deine Schilderung richtig interpretiert habe. Damit solltest du dein Vorhaben realisieren können. Weitere Kommentare befinden sich im Quellcode.
Grüße Uwe
p.s. Bitte nutze in Zukunft Code-Tags für deinen Quellcode:
<code> Quellcode </code>. Merci.
Hallo Uwe,
sorry für die fehlenden Qode-Tags... bin erst seit heute auf administrator.de unterwegs und damit noch nicht ganz vertraut.
Bin immer noch ganz hin und weg von deiner schnellen Antwort!!!
Vielen Dank schon mal für die Datei! Ich werde sie hoffentlich schon morgen ausprobieren können und entsprechende Rückmeldung geben.
Schönen Abend und Grüße
Sascha
sorry für die fehlenden Qode-Tags... bin erst seit heute auf administrator.de unterwegs und damit noch nicht ganz vertraut.
Bin immer noch ganz hin und weg von deiner schnellen Antwort!!!
Vielen Dank schon mal für die Datei! Ich werde sie hoffentlich schon morgen ausprobieren können und entsprechende Rückmeldung geben.
Schönen Abend und Grüße
Sascha
Hallo Uwe,
deine Datei hat wunderbar funktioniert - der Wahnsinn, genau was ich sucht habe!
Allerdings beiße ich mir gerade noch die Zähne an folgenden zwei Dingen aus. Gibt es hierfür eine Lösung?
Es sollen ausschließlich die Zeilen berücksichtigt werden, bei welchen in Spalte D eine 1 steht.
Außerdem habe ich auch Spaltenüberschriften verwendet, die nicht als Mail ausgegeben werden sollen. Wenn ich aber einfach ab A2 statt A1 zu zählen beginne, bekomme ich eine Fehlermeldung bei dic.Add c.Row, ""
Vielleicht gibt es hierfür ja eine Lösung. Vielen Dank vorab für deine Hilfestellungen!
Beste Grüße
Sascha
deine Datei hat wunderbar funktioniert - der Wahnsinn, genau was ich sucht habe!
Allerdings beiße ich mir gerade noch die Zähne an folgenden zwei Dingen aus. Gibt es hierfür eine Lösung?
Es sollen ausschließlich die Zeilen berücksichtigt werden, bei welchen in Spalte D eine 1 steht.
Außerdem habe ich auch Spaltenüberschriften verwendet, die nicht als Mail ausgegeben werden sollen. Wenn ich aber einfach ab A2 statt A1 zu zählen beginne, bekomme ich eine Fehlermeldung bei dic.Add c.Row, ""
Vielleicht gibt es hierfür ja eine Lösung. Vielen Dank vorab für deine Hilfestellungen!
Beste Grüße
Sascha
Sub Aufträge_anschreiben()
'
' Aufträge_anschreiben Makro
'
' Tastenkombination: Strg+m
'
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
Set dic = CreateObject("Scripting.Dictionary")
'Outlook-Objekt erzeugen
Set objOL = CreateObject("Outlook.Application")
'Tabellenblatt referenzieren
Set ws = Worksheets("Makro")
'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
If Not dic.Exists(cell.Row) Then
Dim strMailBody
'Mail erzeugen
Set objMail = objOL.CreateItem(0)
'Eigenschaften der Mail zuweisen
objMail.Subject = "Auftragskorrektur, bitte nachfolgende Aufträge prüfen/bereinigen. Danke und Grüße VKK"
objMail.To = cell.Offset(0, 2).Value
'Mailbody erzeugen aber noch nicht endgültig der Mail zuweisen
strMailBody = cell.Offset(0, 1) & vbNewLine & vbNewLine & cell.Offset(0, 0).Value & vbNewLine
'In Spalte "Sachbearbeiter" nach dem aktuellen Zellwert in Spalte Sachbearbeiter suchen
With rngSource.Offset(cell.Row, 2)
Set c = .Find(cell.Offset(0, 2).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'bearbeitete Zeile zum Dictionary hinzufügen, so dass sie später nicht nochmal verwendet wird
dic.Add c.Row, ""
'dem Mailbody den Inhalt von Spalte A hinzufügen
strMailBody = strMailBody & c.Offset(0, -2) & vbNewLine
'nächste Fundstelle suchen
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
'Mailbody der Mail zuweisen
objMail.Body = strMailBody
'Mail zum testen nur anzeigen
objMail.Display
End If
Next
End SubSub SortedMailing()
Dim ws As Worksheet, rngSource As Range, dic As Object, c As Range, firstAddress As String, cell As Range, lastRow as Long
'Dictionary Objekt erzeugen indem wir die bereits bearbeiteten Zeilen hinterlegen
Set dic = CreateObject("Scripting.Dictionary")
'Outlook-Objekt erzeugen
Set objOL = CreateObject("Outlook.Application")
'Tabellenblatt referenzieren
Set ws = Worksheets(1)
'belegter Range der Zeilen ermnitteln
Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp))
lastRow = rngSource.Cells(rngSource.Rows.Count, 1).Row
'Für jede Zeile im Range
For Each cell In rngSource
' wenn die Zeile noch nicht bearbeitet wurde und in Spalte D eine 1 steht
If Not dic.Exists(cell.Row) And cell.Offset(0, 3).Value = 1 Then
Dim strMailBody
'Mail erzeugen
Set objMail = objOL.CreateItem(0)
'Eigenschaften der Mail zuweisen
objMail.Subject = cell.Value
objMail.To = cell.Offset(0, 1).Value
'Mailbody erzeugen aber noch nicht endgültig der Mail zuweisen
strMailBody = cell.Offset(0, 2).Value & vbNewLine
'In Spalte Y nach dem aktuellen Zellwert in Spalte Y suchen
With ws.Range(ws.Cells(cell.Row + 1, 25), ws.Cells(lastRow, 25))
Set c = .Find(ws.Cells(cell.Row, 25).Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
' Nur wenn in Spalte D eine 1 steht
If ws.Cells(c.Row, 4).Value = 1 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, 1) & 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 = strMailBody
'Mail zum testen nur anzeigen
objMail.Display
End If
Next
End Sub
Guten Morgen Uwe,
das hatte ich genauso gelöst, allerdings poppt mir hier immer die Fehlermeldung bei Zeile 33 auf: "Laufzeitfehler '457': Dieser Schlüssel ist bereits in einem Element dieser AUflistung zugeordnet"...
Die bekomme ich einfach nicht weg!
Grüße
Sascha
das
Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp)) Die bekomme ich einfach nicht weg!
Grüße
Sascha
PROBLEM GELÖST!!
Hallo Uwe,
mir ist aufgefallen, dass ich gar nicht in umbenennen muss, da Zeile 1 schon durch folgende Bedingung ausgeschlossen wird:
Somit erscheint auch nicht die Fehlermeldung und der Code ist für mich perfekt.
Danke vielmals für deine Bemühungen!
Grüße
Sascha
Hallo Uwe,
mir ist aufgefallen, dass ich
Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp)) Set rngSource = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp)) If ws.Cells(c.Row, 4).Value = 1 Then Somit erscheint auch nicht die Fehlermeldung und der Code ist für mich perfekt.
Danke vielmals für deine Bemühungen!
Grüße
Sascha
Moin Sascha,
ich hatte vergessen den Suchbereich nach unten hin zu verkleinern, sorry, ist jetzt oben gefixt.
Grüße Uwe
ich hatte vergessen den Suchbereich nach unten hin zu verkleinern, sorry, ist jetzt oben gefixt.
Grüße Uwe
