Hallo

Ich habe dies mal zusammengebalstelt. Habe aber immer noch das Problem, dass in der selektierten Zelle z.B B4 zwei unterschiedliche Mail adressen stehen und weiter unten z.b B6 in dieser Zelle zwei mail adressen Stehen aber eine ist doppelt mit einer in der Cell B4. wie kriege ich die Doppelten Rausgefilter bvor das mail gneriert wird.

Sub EmailAttachmentRecipients()

'Generiere Pdf
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\PoM_Report_" & Format(Date, "yyyymmdd") _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
  
Dim Datei As String
Datei = ThisWorkbook.Path & "\PoM_Report_" & Format(Date, "yyyymmdd") & ".pdf"

'Generiere E-Mail
    Dim xOutlook As Object
    Dim xMailItem As Object
    Dim xRg As Range
    Dim xCell As Range
    Dim xEmailAddr As String
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the arresses list:", "Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    With xMailItem
        .To = xEmailAddr
        .CC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add Datei
        .Display
    End With
    Set xOutlook = Nothing
    Set xMailItem = Nothing
End Sub