in das Modul der Tabelle 'Aufgaben'. (Rechtsklick auf Register > Code anzeigen)
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Const cstrSubject As String = "Automail aus Excel"
Private Sub Worksheet_Calculate()
Dim rng As Range, rngF As Range
On Error Resume Next
Set rngF = Columns(1).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rngF Is Nothing Then
For Each rng In rngF.Cells
If rng <> "" Then sendMail Cells(rng.Row, 8).Text, cstrSubject, "Neue Aufgabe mit der Nummer " & rng.Text
Next
End If
Set rngF = Nothing
On Error Resume Next
Set rngF = Columns(3).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rngF Is Nothing Then
For Each rng In rngF.Cells
If rng <= 3 Then sendMail Cells(rng.Row, 8).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(rng.Row, 1).Text & " wird in " & Cells(rng.Row, 2).Text & " Tagen fällig"
If rng = 0 Then sendMail Cells(rng.Row, 6).Text & ";" & Cells(rng.Row, 6).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(rng.Row, 1).Text & " ist fällig. Bitte prüfen"
If rng < 0 Then sendMail Cells(rng.Row, 6).Text & ";" & Cells(rng.Row, 6).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(rng.Row, 1).Text & " ist überfällig. Bitte prüfen und neue Absprache"
Next
End If
Set rngF = Nothing
Set rng = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Column = 1 And .Row > 1 And .Value <> "" Then
sendMail Cells(.Row, 8).Text, cstrSubject, "Neue Aufgabe mit der Nummer " & .Text
ElseIf .Column = 13 And .Row > 1 Then
If .Value = "Ja" Then sendMail Cells(.Row, 6).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(.Row, 1).Text & " wurde von " & Cells(.Row, 8) & " Angenommen"
If .Value = "Nein" Then sendMail Cells(.Row, 6).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(.Row, 1).Text & " wurde von " & Cells(.Row, 8) & " abgelehnt. Bitte neu zuordnen oder Rücksprache"
If .Value = "Fertig" Then sendMail Cells(.Row, 8).Text, cstrSubject, "Aufgabe Nummer " & _
Cells(.Row, 1).Text & " ist erledigt"
End If
End With
End Sub
Private Sub sendMail(Receiver As String, Subject As String, Message As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Receiver
.CC = ""
.BCC = ""
.Subject = Subject
.Body = Message
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub