Doppelte Termine in Outlook
01.06.2017 12:39:45
Kurt
eine Frage hätte ich noch zu meinem Code. Es funktioniert soweit alles nur wenn ich das Makro mehrmals ablaufen lasse trägt es mir die Termine immer wieder ein, sodass ich irgendwann den selben Termin 5 mal drin stehen hätte. Ich bräuchte quasi eine Möglichkeit das entweder nur dass was neu eingetragen wurde übernommen wird, oder das die Termine die schon drin stehen einfach ersetzt werden. Kann mir da vllt jemand weiterhelfen?
Mein Code:
Private Sub CommandButton1_Click()
Dim objOutlook As Outlook.Application
Dim apptOutlook As Outlook.AppointmentItem
'Auswahl der ersten Zelle des Kalenders
Range("C5").Select
'Schleife für die Auswahl der nächsten Spalte
Do Until ActiveCell.Value = "Ende"
'Schleife für die Auswahl der nächsten Zeile
Do Until ActiveCell.Value = "Ende"
'Zellen ohne Inhalt werden rausgelassen
If ActiveCell.Value "" Then
'Festlegung der Variabelen
Set objOutlook = CreateObject("Outlook.Application")
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
'Übertragung des Termins in Outlook
With apptOutlook
'Titel des Termins
.Subject = ActiveCell.Value
'Datum des Termins
.Start = Format(Cells(ActiveCell.Row, 1).Value, "dd.mm.yyyy") & " 08:00"
'Inhalt des Termins
.Body = ActiveCell.Comment.Text
'Ort des Termins
.Location = Cells(4, ActiveCell.Column).Value
'Dauer des Termins
.Duration = 60
'Errinerungen an Termin
.ReminderMinutesBeforeStart = 1440
.ReminderPlaySound = True
.ReminderSet = True
'Speichern des Termins
.Save
End With
End If
'Zeilensprung nach unten
ActiveCell.Offset(1, 0).Select
'Löschen der Variablenzuordnung, da Outlook sonst Faxen macht
Set apptOutlook = Nothing
Set objOutlook = Nothing
Loop
'Auswahl der ersten Zelle der Tabelle in der nächsten Spalte
ActiveCell.Offset(0, 1).Select
Cells(5, ActiveCell.Column).Select
Loop
'Nachrichtfenster mit: siehe Klammer
MsgBox ("Termine in Outlook übertragen")
End Sub