Hallo, 

ich habe aktuell einen Code geschrieben um eine automatische Email mit gleichem Anhang an verschiedene Empfänger zu senden.

Nun würde ich gern ebenfalls den "Body" der Email basierend auf einem Word Dokument einfügen, bekomm es aber leider nicht hin.

Aktuell habe ich den "Body" noch von Zelle zu Zelle formatiert.

Vielleicht kann jemand von euch helfen.

Vielen Dank im Voraus.

BG

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Daten")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            

            With OutMail
                .to = cell.Value
                .Subject = cell.Offset(-1, 4).Value
                .Body = cell.Offset(0, 4).Value & " " & cell.Offset(0, -1).Value & "," & Chr(13) & cell.Offset(1, 4).Value & Chr(13) & cell.Offset(2, 4).Value & Chr(13) & cell.Offset(3, 4).Value & Chr(13) & cell.Offset(4, 4).Value & Chr(13) & cell.Offset(5, 4).Value & Chr(13) & cell.Offset(6, 4).Value & Chr(13) & cell.Offset(7, 4).Value & Chr(13) & cell.Offset(8, 4).Value & Chr(13) & cell.Offset(9, 4).Value & Chr(13) & cell.Offset(10, 4).Value & Chr(13) & cell.Offset(11, 4).Value & Chr(13) & cell.Offset(12, 4).Value & Chr(13)
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub