Hallo Peter,

da dein Code gluecklicherweise nicht so lang ist, hab ichs mir zusammengebastelt. Sind ja 2 Codes. Nachfolgend wirst du sehen, wie es aussieht, wenn der Code mit dem Codefenster gepostet wird. Habe mal deinen Code folgendermassen angepasst. In deinem Worksheet_Calculate habe ich mal ein paar Variablen deklariert, Dort wird jetzt per Schleife die gesamte Spalte A durchgegenagen und geprueft, ob der Wert >100 ist. Wenn nein, passiert logischerweise nichts. Wenn ja, wird die entsprechende Zeilennummer als Variable an die Sub "SendMessage" uebergeben. Deshalb dort die Variable "Zeile" in den Klammern. Dann erfolgt der Email Versand und weiter gehts zur naechsten Zeile in Spalte A. Schau mal ob es so funktioniert, oder ob die Verbindung zu Outlook und das Versenden dort eventuell zu lange dauert. Dann muss man noch irgendwo ein Warteereignis einbauen.

Dieser Code ins Worksheet:

Option Explicit

Private Sub Worksheet_Calculate()

Dim lngLastRow As Long, lngzeile As Long
Dim rngZelle As Range, rngRange As Range

lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set rngRange = Range("A1:A" & lngLastRow)

For Each rngZelle In rngRange

    If rngZelle > 100 Then
        lngzeile = rngZelle.Row
        SendMessage (lngzeile)
    End If
Next

End Sub

Und dieser in ein allgemeines Modul:

Option Explicit

Sub SendMessage(Zeile As Long)

Dim oOL As Object
Dim oOLMsg As Object
Dim oOLRecip As Object

Set oOL = CreateObject("Outlook.Application")
Set oOLMsg = oOL.CreateItem(0)
With oOLMsg
    Set oOLRecip = .Recipients.Add(ActiveSheet.Range("G" & Zeile).value)
    .Subject = "Vertrag läuft in 6 Monate aus!"
    .Body = "Kunde: " & ActiveSheet.Range("D" & Zeile)
    .Importance = 0
    .Send
End With

oOLRecip.Resolve
Set oOLMsg = Nothing
Set oOLRecip = Nothing
Set oOL = Nothing

End Sub

Gruss Torsten