Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

VBA Makro Mails aus Excel versenden

Frage Microsoft Microsoft Office

Mitglied: ExxiSt

ExxiSt (Level 1) - Jetzt verbinden

26.08.2014 um 12:13 Uhr, 1917 Aufrufe, 7 Kommentare

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

*
Mitglied: colinardo
LÖSUNG 26.08.2014, aktualisiert 28.08.2014
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.
Bitte warten ..
Mitglied: ExxiSt
26.08.2014 um 20:51 Uhr
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
Bitte warten ..
Mitglied: ExxiSt
27.08.2014 um 16:31 Uhr
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

01.
Sub Aufträge_anschreiben() 
02.
03.
' Aufträge_anschreiben Makro 
04.
05.
' Tastenkombination: Strg+m 
06.
07.
    Dim ws As Worksheet, rngSource As Range, dic As Object, c As Range, firstAddress As String, cell As Range 
08.
    'Dictionary Objekt erzeugen indem wir die bereits bearbeiteten Zeilen hinterlegen 
09.
        
10.
    Set dic = CreateObject("Scripting.Dictionary") 
11.
    'Outlook-Objekt erzeugen 
12.
    Set objOL = CreateObject("Outlook.Application") 
13.
    'Tabellenblatt referenzieren 
14.
    Set ws = Worksheets("Makro") 
15.
     
16.
    'belegter Range der Zeilen ermnitteln 
17.
    Set rngSource = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp)) 
18.
    'Für jede Zeile im Range 
19.
    For Each cell In rngSource 
20.
        ' wenn die Zeile noch nicht bearbeitet wurde 
21.
        If Not dic.Exists(cell.Row) Then 
22.
            Dim strMailBody 
23.
            'Mail erzeugen 
24.
            Set objMail = objOL.CreateItem(0) 
25.
            'Eigenschaften der Mail zuweisen 
26.
            objMail.Subject = "Auftragskorrektur, bitte nachfolgende Aufträge prüfen/bereinigen. Danke und Grüße VKK" 
27.
            objMail.To = cell.Offset(0, 2).Value 
28.
            'Mailbody erzeugen aber noch nicht endgültig der Mail zuweisen 
29.
            strMailBody = cell.Offset(0, 1) & vbNewLine & vbNewLine & cell.Offset(0, 0).Value & vbNewLine 
30.
             
31.
            'In Spalte "Sachbearbeiter" nach dem aktuellen Zellwert in Spalte Sachbearbeiter suchen 
32.
            With rngSource.Offset(cell.Row, 2) 
33.
                Set c = .Find(cell.Offset(0, 2).Value, LookIn:=xlValues, Lookat:=xlWhole) 
34.
                If Not c Is Nothing Then 
35.
                    firstAddress = c.Address 
36.
                    Do 
37.
                        'bearbeitete Zeile zum Dictionary hinzufügen, so dass sie später nicht nochmal verwendet wird 
38.
                        dic.Add c.Row, "" 
39.
                        'dem Mailbody den Inhalt von Spalte A hinzufügen 
40.
                        strMailBody = strMailBody & c.Offset(0, -2) & vbNewLine 
41.
                        'nächste Fundstelle suchen 
42.
                        Set c = .FindNext(c) 
43.
                    Loop While Not c Is Nothing And c.Address <> firstAddress 
44.
                End If 
45.
            End With 
46.
            'Mailbody der Mail zuweisen 
47.
            objMail.Body = strMailBody 
48.
            'Mail zum testen nur anzeigen 
49.
            objMail.Display 
50.
        End If 
51.
     
52.
     
53.
    Next 
54.
 
55.
 
56.
End Sub 
57.
 
Bitte warten ..
Mitglied: colinardo
LÖSUNG 27.08.2014, aktualisiert 28.08.2014
01.
Sub SortedMailing() 
02.
    Dim ws As Worksheet, rngSource As Range, dic As Object, c As Range, firstAddress As String, cell As Range, lastRow as Long 
03.
    'Dictionary Objekt erzeugen indem wir die bereits bearbeiteten Zeilen hinterlegen 
04.
    Set dic = CreateObject("Scripting.Dictionary") 
05.
    'Outlook-Objekt erzeugen 
06.
    Set objOL = CreateObject("Outlook.Application") 
07.
    'Tabellenblatt referenzieren 
08.
    Set ws = Worksheets(1) 
09.
    'belegter Range der Zeilen ermnitteln 
10.
    Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp)) 
11.
    lastRow = rngSource.Cells(rngSource.Rows.Count, 1).Row 
12.
    'Für jede Zeile im Range 
13.
    For Each cell In rngSource 
14.
        ' wenn die Zeile noch nicht bearbeitet wurde und in Spalte D eine 1 steht 
15.
        If Not dic.Exists(cell.Row) And cell.Offset(0, 3).Value = 1 Then 
16.
            Dim strMailBody 
17.
            'Mail erzeugen 
18.
            Set objMail = objOL.CreateItem(0) 
19.
            'Eigenschaften der Mail zuweisen 
20.
            objMail.Subject = cell.Value 
21.
            objMail.To = cell.Offset(0, 1).Value 
22.
            'Mailbody erzeugen aber noch nicht endgültig der Mail zuweisen 
23.
            strMailBody = cell.Offset(0, 2).Value & vbNewLine 
24.
             
25.
            'In Spalte Y nach dem aktuellen Zellwert in Spalte Y suchen 
26.
            With ws.Range(ws.Cells(cell.Row + 1, 25), ws.Cells(lastRow, 25)) 
27.
                Set c = .Find(ws.Cells(cell.Row, 25).Value, LookIn:=xlValues, Lookat:=xlWhole) 
28.
                If Not c Is Nothing Then 
29.
                    firstAddress = c.Address 
30.
                    Do 
31.
                        ' Nur wenn in Spalte D eine 1 steht 
32.
                        If ws.Cells(c.Row, 4).Value = 1 Then 
33.
                            'bearbeitete Zeile zum Dictionary hinzufügen, so dass sie später nicht nochmal verwendet wird 
34.
                            If Not dic.Exists(c.Row) Then dic.Add c.Row, "" 
35.
                            'dem Mailbody den Inhalt von Spalte Z hinzufügen 
36.
                            strMailBody = strMailBody & c.Offset(0, 1) & vbNewLine 
37.
                            'nächste Fundstelle suchen 
38.
                        End If 
39.
                        Set c = .FindNext(c) 
40.
                    Loop While Not c Is Nothing And c.Address <> firstAddress 
41.
                End If 
42.
            End With 
43.
            'Mailbody der Mail zuweisen 
44.
            objMail.Body = strMailBody 
45.
            'Mail zum testen nur anzeigen 
46.
            objMail.Display 
47.
        End If 
48.
    Next 
49.
End Sub
Grüße Uwe
Bitte warten ..
Mitglied: ExxiSt
28.08.2014 um 08:02 Uhr
Guten Morgen Uwe,

das
01.
 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
Bitte warten ..
Mitglied: ExxiSt
28.08.2014 um 08:15 Uhr
PROBLEM GELÖST!!

Hallo Uwe,

mir ist aufgefallen, dass ich
01.
 Set rngSource = ws.Range("A2", ws.Cells(Rows.Count, 1).End(xlUp)) 
gar nicht in
01.
 Set rngSource = ws.Range("A1", ws.Cells(Rows.Count, 1).End(xlUp)) 
umbenennen muss, da Zeile 1 schon durch folgende Bedingung ausgeschlossen wird:
01.
 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
Bitte warten ..
Mitglied: colinardo
28.08.2014 um 09:35 Uhr
Moin Sascha,
ich hatte vergessen den Suchbereich nach unten hin zu verkleinern, sorry, ist jetzt oben gefixt.

Grüße Uwe
Bitte warten ..
Neuester Wissensbeitrag
Microsoft

Lizenzwiederverkauf und seine Tücken

(5)

Erfahrungsbericht von DerWoWusste zum Thema Microsoft ...

Ähnliche Inhalte
Microsoft Office
gelöst CSV-Datei mit einem VBA Makro in Excel einlesen und leicht anpassen (5)

Frage von JoSiBa zum Thema Microsoft Office ...

Outlook & Mail
gelöst Ganztägier Outlooktermin per VBA aus Excel versenden (8)

Frage von Piotor04 zum Thema Outlook & Mail ...

Heiß diskutierte Inhalte
LAN, WAN, Wireless
FritzBox, zwei Server, verschiedene Netze (17)

Frage von DavidGl zum Thema LAN, WAN, Wireless ...

Windows Netzwerk
Windows 10 RDP geht nicht (16)

Frage von Fiasko zum Thema Windows Netzwerk ...

Windows Server
Outlook Verbindungsversuch mit Exchange (15)

Frage von xbast1x zum Thema Windows Server ...