Termine übertragen
02.06.2017 08:17:59
Kurt
Ich habe ein kleines Problem beim übertragen von Terminen aus Excel in Outlook via Makro. Es ist nämlich so, dass mit jeder Makro Aktivierung alle Termine wieder übernommen werden und es so zu Dopplungen kommt. Wie kann ich das verhindern?
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