Makro funktioniert nicht - Was muss ich ändern?
27.04.2016 12:18:46
Sirka
ich brauche eure Hilfe.
ich versuche ein Makro zu schreiben, aber ich bin totaler Anfänger und verstehe nicht wie ich das hinbekomme.
Beim Ausführen des Makros sollen automatisch E-Mail-Vorlagen geöffnet werden, die ich dann manuell abschicken will.
In dem Beispiel unten sollen alle Personen die in Spalte K eine Zahl größer als Null haben eine E-Mail an die in Spalte Q hinterlegte Adresse bekommen. Die richtige Datei hat ca. 400 Zeilen, die alle auf einen Wert größer als Null in Spalte K überprüft werden müssen.
Beispiel für E-Mail:
Spalte A: MustermannMax
Spalte K: 2
Spalte Q: Max.Mustermann@firma.de
Beispiel für keine E-Mail:
Spalte A: MustermannTina
Spalte K: 0
Spalte Q: Tina.Mustermann@firma.de
Das was ich bisher habe habe ich mir zusammenkopiert und mit meinen Daten ergänzt.
In Spalte L wird mir beim ausführen des Makros "Sent" und "Not Sent" angezeigt aber sonst tut sich leider gar nichts. was muss ich ändern, damit die Mail-Entwürfe geöffnet werden?
Option Explicit
Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim FormulaCell As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
MyLimit = 0
Set FormulaRange = Range("K2:K8")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = "Not numeric"
Else
If .Value > MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook1(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
Sub Mail_with_outlook1(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim str
Sub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(FormulaCell.Row, "Q").Value
strcc = ""
strbcc = ""
str
Sub = "offene Punkte"
strbody = "Guten Tag, " & vbNewLine & vbNewLine & "Sie haben " & Cells(FormulaCell.Row, "B"). _
Value & " offene Punkte. Bitte arbeiten Sie diese ab" & _
vbNewLine & vbNewLine & "Mit freundlichen Grüßen," & _
vbNewLine & vbNewLine & "Abteilung XY"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Vielen Dank für eure Hilfe!