Hallo zusammen,

evtl. kann mir einer Helfen ich habe mir diesen Coder gebastelt, Leider überschreibt er die eingefügten Inhalte in der Email.

Sub EmailErstellen()
Dim olApp As Object ' Outlook-Anwendung
Dim olMail As Object ' Neue E-Mail
Dim rng As Range ' Bereich, der in die E-Mail kopiert werden soll
Dim strBody As String ' Body-Text der E-Mail

' Erstelle einen Verweis auf die Outlook-Anwendung
Set olApp = CreateObject("Outlook.Application")

' Erstelle eine neue E-Mail
Set olMail = olApp.CreateItem(0)

' Definiere den Body-Text der E-Mail
strBody = "Hallo zusammen," & vbCrLf & vbCrLf & _
"Hier die Daten aus dem Schichtbericht zum Ereignis."

' Definiere den Bereich, der in die E-Mail kopiert werden soll
' Achtung: Stelle sicher, dass die Zellen ausgewählt sind, bevor du den Code ausführst
Set rng = Selection

' Füge den Text zum Body-Text der E-Mail hinzu
olMail.Body = strBody & vbCrLf & vbCrLf

olMail.Display

' Kopiere den Text in die Zwischenablage
Range("A1").Value = strBody
Range("A1").Copy

' Füge den Text in die E-Mail ein
olMail.GetInspector.WordEditor.Range.Paste

' Füge eine Leerzeile ein
olMail.GetInspector.WordEditor.Range.Text = vbCrLf & vbCrLf

' Füge den Zellbereich in die E-Mail ein
rng.Copy
olMail.GetInspector.WordEditor.Range.Paste

' Öffne die E-Mail zum Überprüfen oder zum Senden
olMail.Display

' Reinige die Objektvariablen
Set olMail = Nothing
Set olApp = Nothing
Set rng = Nothing
End Sub

Vielen Dank schön mal für eure Hilfe