automatisches EMail wenn Wert überschritten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
habe hier mal was zusammengestellt, vielleicht passt es so.
kommt als Code in DieseArbeitsmappe

Option Explicit 
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) 
Call CheckGrenzwerte 
End Sub

kommt als Code in Modul1

Option Explicit 
Dim lvntTaskId As Double 
 
Sub CheckGrenzwerte() 
Dim MaxRow&, strRange$ 
 
Const MailAdresse$ = "Empfänger@Proviter.de" 'Mail-Adresse 
 
With Tabelle1 
    MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row 
    If MaxRow < 2 Then Exit Sub 
    With .UsedRange 
        With .Columns(.Columns.Count).Offset(0, 1) 
            .FormulaR1C1 = "=IF(AND(COUNTIF(RC3:RC14,"">""&RC2),ROW()>1),TRUE,"""")" 
             
            On Error Resume Next 
                strRange = .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Address(0, 0) 
                .Clear 
            On Error GoTo 0 
        End With 
    End With 
 
    If strRange <> "" Then 
        Call Open_Outlook 
        MailSenden MailAdresse, strRange 
    End If 
End With 
End Sub 
 
Sub MailSenden(strAn$, strRange$) 
Dim MyOutApp As Object, MyMessage As Object 
Set MyOutApp = CreateObject("Outlook.Application") 
Set MyMessage = MyOutApp.CreateItem(0) 
With MyMessage 
    .To = strAn 
    .Subject = "Grenzwert" 
    .body = "Grenzwert überschritten " & ThisWorkbook.Name & vbCr & vbCr & strRange 
    .Importance = 2 'Wichtigkeit hoch 
    .Display 'hier Anzeigen 
    '.Send 'Hier wird die Mail gesendet 
End With 
 
Set MyOutApp = Nothing 
Set MyMessage = Nothing 
End Sub 
 
 
 
Sub Open_Outlook() 
Dim strPath$, oApp As Object 
On Error Resume Next 
Set oApp = GetObject(, "Outlook.Application") 
If Err.Number = 0 Then Exit Sub 
strPath = Application.Parent.Path 
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" 
lvntTaskId = Shell(strPath & "OUTLOOK.EXE", vbMinimizedFocus) 
End Sub

Gruß Tino

Sub CheckGrenzwerte() Dim MaxRow&, n&, strRange$, arAdress Dim Regex As Object Const MailAdresse$ = "Empfänger@Proviter.de" 'Mail-Adresse With Tabelle1 MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row If MaxRow < 2 Then Exit Sub With .UsedRange With .Columns(.Columns.Count).Offset(0, 1) '*** Entsprechende Formel bei FormulaR1C1 einsetzen 'für aktuellen Monat '"=IF(AND(COUNTIF(INDEX(RC3:RC14,,MONTH(TODAY())),"">""&RC2),ROW()>1),TRUE,"""")" 'für den letzten Eintrag '"=IF(AND(COUNTIF(INDEX(RC3:RC14,,MAX(LOOKUP(2,1/(RC3:RC14<>""""),COLUMN(RC3:RC14)))-2),"">""&RC2),ROW()>1),TRUE,"""")" .FormulaR1C1 = "=IF(AND(COUNTIF(INDEX(RC3:RC14,,MONTH(TODAY())),"">""&RC2),ROW()>1),TRUE,"""")" On Error Resume Next strRange = .SpecialCells(xlCellTypeFormulas, 4).EntireRow.Address(0, 0) .Clear On Error GoTo 0 End With End With If strRange <> "" Then Call Open_Outlook Set Regex = CreateObject("Vbscript.Regexp") With Regex .Pattern = "[:]{1,1}\d+" .MultiLine = True .Global = True strRange = Replace(.Replace(strRange, ""), ",", ", ") End With strRange = "In Zeile:" & vbCr & vbCr & strRange MailSenden MailAdresse, strRange End If End With Set Regex = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

automatisches EMail wenn Wert überschritten

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

automatisches EMail wenn Wert überschritten

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

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread