Hallo Zwei Fragen zu Ihrem Cod 

Frage 1.

Wenn Zwei Nahmen in einer Zelle Stehen dann Schreibt er Anschliessen Beide Nahmen Rein eine Mit Mail adresse die andere ohne

B4= Anna Thomson Sigfrid Mund

B5= Sigfrid Mund

nach aussführung des Makros sthet:

B4= Anna.Thomson Sigfrid.Mund@xy.com

B5= Sigfrid.Mund@xy.com

Sollte eigendlich stehen

B4= Anna.Thomsonxy.com Sigfrid.Mund@xy.com

B5= ""

Frage2.

Sie Schreiben das Dictionaryobjekt also das "myAddresses.Keys " kann für das Versenden Verwendet werden. Wie kriege ich dies in .To = 

geschrieben wird?

Danke für Ihre Hilfe

Sub EmailAttachmentRecipients()

    Dim i      As Long, x As Long, cnt As Long
    Dim arr
    Dim strAdr As String
    Dim myAddresses As Object
    Set myAddresses = CreateObject("Scripting.Dictionary")
    
    i = 2  'startzeile
    
    'Zellwerte zeilenweise aufteilen
    Do While Cells(i, 1) <> ""
       arr = Split(Cells(i, 1), ";")
    'Spalte
       Cells(i, 2).Resize(, UBound(arr) + 1) = arr
      i = i + 1
    Loop
     
    'adressen umschreiben und in dictionary speichern
    For x = 2 To i - 1
     For cnt = 2 To UsedRange.SpecialCells(xlCellTypeLastCell).Column
          If Cells(x, cnt).Value <> "" Then
            strAdr = Replace(Trim(Cells(x, cnt).Value), " ", ".")
            strAdr = strAdr & "@xy.com"
            If Not myAddresses.Exists(strAdr) Then
              myAddresses.Add strAdr, 1
            End If
          End If
     Next cnt
   Next x
  ' alternativ zu nachfolgenden Code  myAddresses.Keys für den Mailversand verwenden
   'adressen in Tabellenblatt schreiben
   Range(Cells(2, 2), Cells(x, cnt)).ClearContents
   Cells(2, 2).Resize(myAddresses.Count).Value = Application.Transpose(myAddresses.Keys)
   Columns(2).AutoFit

'**************************************************************************************
'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 xEmailAddr As String

    On Error Resume Next

    Set xOutlook = CreateObject("Outlook.Application")
    Set xMailItem = xOutlook.CreateItem(0)

    With xMailItem
        .To = myAddresses.Keys
        .CC = ""
        .Subject = ""
        .Body = ""
        .Attachments.Add Datei
        .Display
    End With
    Set xOutlook = Nothing
    Set xMailItem = Nothing
    Sheets("Report").Select
End Sub