exxist
Aug 26, 2014
view5097
view7
0
Goto Top

VBA Makro Mails aus Excel versenden

GermansolvedQuestionMicrosoft OfficeMicrosoft
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

*
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 247434

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

Printed on: April 19, 2024 at 15:04 o'clock

7 Comments
Latest comment
Goto Top
Member: colinardo
Solution colinardo Aug 26, 2014, updated at Aug 28, 2014 at 06:21:34 (UTC)
Goto Top
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: <code> Quellcode </code>. Merci.
Member: ExxiSt
ExxiSt Aug 26, 2014 at 18:51:49 (UTC)
Goto Top
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
Member: ExxiSt
ExxiSt Aug 27, 2014 at 14:31:48 (UTC)
Goto Top
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

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 Sub
Member: colinardo
Solution colinardo Aug 27, 2014, updated at Aug 28, 2014 at 07:34:07 (UTC)
Goto Top
Sub 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
Grüße Uwe
Member: ExxiSt
ExxiSt Aug 28, 2014 at 06:02:59 (UTC)
Goto Top
Guten Morgen Uwe,

das 
 Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp))
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
Member: ExxiSt
ExxiSt Aug 28, 2014 at 06:15:33 (UTC)
Goto Top
PROBLEM GELÖST!!

Hallo Uwe,

mir ist aufgefallen, dass ich 
 Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp))
gar nicht in 
 Set rngSource = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp))
umbenennen muss, da Zeile 1 schon durch folgende Bedingung ausgeschlossen wird: 
 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
Member: colinardo
colinardo Aug 28, 2014 at 07:35:41 (UTC)
Goto Top
Moin Sascha,
ich hatte vergessen den Suchbereich nach unten hin zu verkleinern, sorry, ist jetzt oben gefixt.

Grüße Uwe
GermansolvedQuestionMicrosoft OfficeMicrosoft
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsjstrickerWIREGUARD VPN ON UDM PRO BEHIND FRITZBOX - HANDSHAKE DID NOT COMPLETEjstricker - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment