AW: Automatische E-Mail senden wenn Datum 1 Jahr überschritten
24.01.2024 09:00:18
MCO
Moin, Sascha!
Das tut, was es soll.
Erläuterung in den Kommentaren. Den Mailtext kannst du direkt in HTML verfassen um zu formatieren.
Probier es mal aus.
Sub Mail_nach_Datum()
Dim cl As Range
Dim addr As String
Dim lzeil As Long
Dim lcol As Long
Dim MA_Name As String
Dim Bereich As String
Dim text As String
Dim Betreff As String
lzeil = Cells.SpecialCells(xlCellTypeLastCell).Row
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
For Each cl In Range("C3", Cells(lzeil, lcol)).SpecialCells(xlCellTypeConstants)
If CDate(cl.Value) Date - 365 Then 'Datumsprüfung
MA_Name = Cells(cl.Row, "A")
Bereich = Cells(2, cl.Column)
'Debug.Print MA_Name, Bereich
addr = "Hier muss irgendwie die mailadresse von " & MA_Name & " stehen"
Betreff = "Schulung abgelaufen: " & Bereich
text = "Hallo " & Trim(Split(MA_Name, " ")(0)) & ",
" & _
"die MA-Schulung im Bereich " & Bereich & " ist abgelaufen" & Chr(10) & _
"
Du musst was tun!
"
mail addr, Betreff, text, 0, 0 'die erste Null bestimmt ob sofort gesendet wird oder erst angezeigt. Zum Testen: 0
End If
Next cl
End Sub
Sub mail(send_to As String, _
Betreff As String, _
text As String, _
sofort_senden As Boolean, _
del_gesendet As Boolean, _
Optional Kopie_an As String, _
Optional anhang As String)
'Mails versenden mit nur 1 Zeile
'Beispielzeile
'mail "Böhmermann, Jan", "Hier der Betreff", "Testtext",0 , 1
On Error GoTo 0
Dim MyMessage As Object, MyOutApp As Object, myOlApp, htlm_Vorgabe As String
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = send_to
.cc = Kopie_an
.Subject = Betreff
.Display '.GetInspector.Display
.DeleteAfterSubmit = del_gesendet
.htmlbody = "" & text & "" & .htmlbody '= 'Signature
If anhang > "" Then .attachments.Add anhang
If sofort_senden Then .send 'Else .Display
End With
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Gruß, MCO