AW: Email versenden an mehrere Empfänger
11.03.2020 18:58:45
Regina
Hi Patrick,
dert Laufzeitfehler erscheint, weil Du mit UsedRange arbeitest und das auch Formatierungen (Rahmen) mit einschließt. Außerdem füllst Du weiter unten die Variable "Adressaten", nutzt sie dann aber nicht.
Hier der überarbeitete Code. Teste mal, ob das jetzt läuft:
Sub Excel_Control_Schachtmeister_nach_Outlook()
'E 2000
'Dim OutApp As Outlook.Application
Dim OutApp As Object, apptOutApp As Object
'Hier beginnen die Termine
Dim BlattName As String
Dim Zeile As Integer
BlattName = "Schachtmeister"
EmailNamen = "patrick.gruel@strabag.com; heike.harslem@strabag.com" 'hier können auch Termin an _
Emailempfänger versendet werden, Adressen mit Semikolon trennen
For Zeile = 2 To Sheets(BlattName).Cells(Rows.Count, 2).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem
If Sheets(BlattName).Cells(Zeile, 10) > 0 Then 'Datum vorhanden
If IsEmpty(Sheets(BlattName).Cells(Zeile, 12)) = True Then 'Status ohne Wert
With apptOutApp
'Datum wird die Termine aus der Zelle genommen
.Start = Format(Sheets(BlattName).Cells(Zeile, 10), "dd.mm.yyyy") & " 08:00"
'Termininfo
.Subject = "Erinnerung Abgabe Stundenberichte: " & Sheets(BlattName).Cells(Zeile, 7)
'Zusätzlicher Text
Nachricht = Sheets(BlattName).Cells(Zeile, 8) & Chr(10)
'Nachricht = Nachricht & "weiterer Text möglich"
.Body = Nachricht
'Anzeige
.display
'ort
.Location = "Stundenberichte: " & Sheets(BlattName).Cells(Zeile, 7)
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
.Duration = "5"
'Erinnerung
.ReminderMinutesBeforeStart = "20"
'mit Sound :-)
.ReminderPlaySound = True
'Erinnerung wiederholen
.ReminderSet = True
'Wichtigkeit
.Importance = olImportanceHigh
'Status
.MeetingStatus = olMeeting
'Optionale Adressen
.OptionalAttendees = "EmailNamen"
Application.DisplayAlerts = False
'Termin speichern
.Save
'Schließen ohne senden
'Application.SendKeys "%DL"
'Senden an anderen EmailAdressen (Aktivierung: 1. Zeichen bei den nächsten 2 Zeilen _
entfernen)
OptionalAttendees = "EmailNamen"
' Application.SendKeys "%S" '*** automatisch ohne überprüfung senden ***
Application.DisplayAlerts = True
'Erledigt setzen
Sheets(BlattName).Cells(Zeile, 12) = "in Outlook übernommen"
End With
'ActiveCell.Offset(1, 0).Select
'Variablen leeren,
End If
End If
Set apptOutApp = Nothing
Set OutApp = Nothing
Next Zeile
'MsgBox "Termine an Outlook übertragen!"
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
Dim Adressaten As String
Dim z As Range
For Each z In Range("F2:F" & Worksheets(BlattName).Cells(Rows.Count, 2).End(xlUp).Row)
If z "" Then
Adressaten = Adressaten & ";" & z
End If
Next
.Subject = "Erinnerung Stundenberichte"
.Body = Nachricht
.To = Adressaten
'.cc = "" 'per Kopie
'.bcc = "" 'per Blindkopie
' .send 'versand erfolgt automatisch!
.display 'Versand erfolgt manuell
End With
Set OutlookApp = Nothing
Set OutlookMailItem = Nothing
End Sub
Gruß Regina