Email Makro mit von auswählen

Sub Email_Partner_NB()
Dim i As Long, tmpStr As String
tmpStr = ""
For i = 2 To 1000
tmpStr = tmpStr & Cells(i, 5).Value & Chr$(10)
Next i
With Cells(2, 5)
.Value = Left(tmpStr, Len(tmpStr) - 2)
.WrapText = True
End With
'--> Email:
Dim rng As Range
Dim olapp As Object
Set olapp = CreateObject("Outlook.Application")
With olapp.CreateItem(0)
Set rng = Selection
.Body = Range("k1")
.bcc = Cells(2, 5)
.Subject = "Ausschreibung getenergy " & Format(Date, "dd.mm.yy")
'.ReadReceiptRequested = True ' optional Lesbestätigung anfordern
.Display
End With
Set rng = Nothing
Set olapp = Nothing
'--> Empfänger löschen und Filter zurücksetzen
Range("e2").Select
Selection.ClearContents
Range("d4:d1500").Select
Selection.ClearContents
Range("A1").Select
End Sub