Automatische Erinnerungsmail senden

Hallo,
ich habe seit einigen Wochen ein Problem, dass ich nicht lösen kann und auch nach intensiver Recherche keine Lösung gefunden, die ich umsetzen kann.
Folgendes:
Es soll erstmals 14 Tage nach einem bestimmten Datum (Auftragsdatum, steht bereits in einer Zelle) eine Mail mit Textvorlage in meinem Standard-Mailprogramm verfasst werden, die dann über den Senden-Button abgeschickt werden kann.
Die Variablen im Mailtext sollen sich automatisch anpassen (ähnlich SVerweis), diese sind auch aus bestehenden Zellen auslesbar.
Aktuell kann ich das, aber nur manuell über die HYPERLINK-Formel (mailto) Es soll aber automatisiert werden.
Wenn die Mail erstmals nach 14 Tagen verfasst wurde, soll danach alle 7 Tage eine weitere Erinnerungsmail verfasst werden. Das soll so lange laufen, bis in einer anderen Zelle ein Wareneingangsdatum eingetragen wurde.
Vermutlich ist hier VBA nötig, und da hört es bei mir auf. :-(
Viele Grüße
Max

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public strTo As String, strCc As String, strSubj As String, strBody As String Sub AutoSend() Dim iZeile As Integer, iLR As Integer, dWo As Double, iZ1 As Integer Dim AfDat As Date, WeDat As Date iZ1 = 3 'erste Zeile mit Daten With Sheets("Einzelaufstellung (ändern)") iLR = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte For iZeile = iZ1 To iLR If .Cells(iZeile, 2) "" Then AfDat = .Cells(iZeile, 4) WeDat = .Cells(iZeile, 10) 'noch kein WE und keine mail seit 14 Tagen If WeDat = 0 And Date - AfDat > 14 Then 'noch keine mail oder letzte mail älter als 7 Tage If .Cells(iZeile, 15) = "" Or Date - .Cells(iZeile, 15) > 7 Then ' Letzte mail eintragen in Spalte O .Cells(iZeile, 15) = Date 'Woche dWo = Round((Date - AfDat) / 7, 1) 'Mail zusammenbauen strTo = .Cells(iZeile, 2) strCc = "" strSubj = "Kom. " & .Cells(iZeile, 3) & " / Erinnnerung" strBody = "Automatische Erinnerung &LTp>&LTp> " & _ "Für Kom. " & .Cells(iZeile, 3) & " ist seit " & dWo & " Wochen keine Ware zur Verarbeitung eingetroffen." strBody = strBody & "&LTp>&LTp>&LTp>&LTp> Mit freundlichen Grüßen &LTp>&LTp> Ihr Team von XYZ" Call send_Email(strTo, strCc, strSubj, strBody) End If End If End If Next End With End Sub Sub send_Email(strTo, strCc, strSubj, strBody) Dim olApp As Object Set olApp = CreateObject("Outlook.Application") With olApp.CreateItem(0) .Subject = strSubj .To = strTo .Cc = strCc .htmlbody = strBody .Display 'anzeigen '.SendMail 'direkt senden End With Set olApp = Nothing End Sub

Hallo
Prima dass es läuft
Zu 1)
Schreibe in den Codebereich von DieseArbeitsmappe


Private Sub Workbook_Open()
Call AutoSend
End Sub

Zu 2)
Habe ich erweitert


Option Explicit
Public strTo As String, strCc As String, strSubj As String, strBody As String
Sub AutoSend()
Dim iZeile As Integer, iLR As Integer, dWo As Double, iZ1 As Integer
Dim AfDat As Date, WeDat As Date
iZ1 = 3 'erste Zeile mit Daten
With Sheets("Einzelaufstellung (ändern)")
iLR = .Cells(.Rows.Count, "B").End(xlUp).Row 'letzte Zeile der Spalte
For iZeile = iZ1 To iLR
If .Cells(iZeile, 2)  "" Then
AfDat = .Cells(iZeile, 4)
WeDat = .Cells(iZeile, 10)
'noch kein WE und keine mail seit 14 Tagen
If WeDat = 0 And Date - AfDat > 14 Then
'noch keine mail oder letzte mail älter als 7 Tage
If .Cells(iZeile, 15) = "" Or Date - .Cells(iZeile, 15) > 7 Then
'Prüfen ob es sich um gleichen Kunden, gleiche Kommission handelt
'und bereits eine mail für HEUTE vorliegt
If WorksheetFunction.CountIfs(.Cells(iZ1, 2).Resize(iZeile - iZ1 + 1, 1), .Cells(iZeile, 2), _
.Cells(iZ1, 3).Resize(iZeile - iZ1 + 1, 1), .Cells(iZeile, 3), _
.Cells(iZ1, 15).Resize(iZeile - iZ1 + 1, 1), "&date") &LTp> " & _
"Für Kom. " & .Cells(iZeile, 3) & " ist seit " & dWo & " Wochen keine Ware zur Verarbeitung eingetroffen."
strBody = strBody & "&LTp>&LTp>&LTp>&LTp> Mit freundlichen Grüßen &LTp>&LTp> Ihr Team von XYZ"
Call send_Email(strTo, strCc, strSubj, strBody)
Else
'Bei Bedarf keine mail bei Wiederholung, aber trotzdem Datum reinschreiben
.Cells(iZeile, 15) = Date
End If
End If
End If
End If
Next
End With
End Sub
Sub send_Email(strTo, strCc, strSubj, strBody)
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.Subject = strSubj
.To = strTo
.Cc = strCc
.htmlbody = strBody
.Display 'anzeigen
'.SendMail 'direkt senden
End With
Set olApp = Nothing
End Sub

LG UweD

Private Sub Workbook_Open() Call Tabelle4.AutoSend End Sub

Beliebteste Forumthreads (12 Monate)

Automatische Erinnerungsmail senden

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread