Option Explicit
Sub Test()
Dim rng As Excel.Range
Dim strMail As String
With Worksheets("Tabelle1").Columns("A")
Set rng = .Find("x", , xlValues, xlWhole, xlByColumns, MatchCase:=False)
If Not rng Is Nothing Then
strMail = rng.Offset(0, 1).Value
Dim Empfänger As String, Betreff As String
Dim OutApp As Object, Mail As Object, i
Dim ClpObj As DataObject
Dim Nachricht
Empfänger = strMail
Betreff = "Angebot"
Set ClpObj = New DataObject
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Empfänger
.Subject = Betreff
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
Else
MsgBox "Keine Eintrag markiert."
End If
End With
End Sub