Outlook-Verteiler automatisch verändern
27.04.2017 09:14:36
Sa
ich habe einen Code erstellt, mit dessen Hilfe ich eine Excel-Datei automatisch in Outlook packe. Der Verteiler wird je nach Zelleninhalt automatisch ausgewählt.
Das Problem hierbei ist, dass manche Personen sich auch selber die Mail schicken, weil sie im Verteiler sind. Jetzt muss jedes mal händisch die eigenen Adresse entfernt werden. Kann man das nicht ins Makro einbauen, dass erkannt wird, von welcher email-Adresse die Nachricht verschickt wird und wenn die mit dem Namen im Verteiler übereinstimmt,dann erst gar nicht in den Verteiler aufnehmen?
Das Makro ist auch sehr langsam. Wie kann man das schneller machen?
Liebe Grüße
Sa
Sub Schaltfläche3243_KlickenSieAuf()
'Variabler Outlookverteiler je Businessteam
Dim Nachricht As Object, OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim AWS As String
ActiveWorkbook.Save
'Aktive Arbeitsmappe wird als Mail gesendet
AWS = ThisWorkbook.FullName
Quelle = ActiveWorkbook.ActiveSheet.Name
Set Nachricht = OutApp.CreateItem(0)
If Sheets("Test request").Range("F2").Value = "Label" Then
With Nachricht
.To = "m.rh@t.com" & "; S.S@t.com" & "; K.W@t.com"
.CC = "R.K@.com"
.Subject = "Test request" & " " & Range("F2") & ":" & " " & Range("D10").Value
.attachments.Add AWS
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'Mail.Send
End With
Else
End If
If Sheets("Test request").Range("F2").Value = "Packaging" Then
With Nachricht
.To = "m@t.com" & "; D@t.com"
.CC = "R.@t.com"
.Subject = "Test request" & " " & Range("F2") & ":" & " " & Range("D10").Value
.attachments.Add AWS
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'Mail.Send
End With
Else
End If
If Sheets("Test request").Range("F2").Value = "Tobacco" Then
With Nachricht
.To = "m@t.com" & "; Td@t.com"
.CC = "Ru@t.com"
.Subject = "Test request" & " " & Range("F2") & ":" & " " & Range("D10").Value
.attachments.Add AWS
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'Mail.Send
End With
Else
End If
If Sheets("Test request").Range("F2").Value = "Technical" Then
With Nachricht
.To = "m@t.com" & "; B@an.com"
.CC = "R@t.com"
.Subject = "Test request" & " " & Range("F2") & ":" & " " & Range("D10").Value
.attachments.Add AWS
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'Mail.Send
End With
Else
End If
End Sub