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
|