Hi,
I have the following macro that adds calendar items from my spreadsheet:
Sub UpdateCalendar()
'macro to update the outlook calendar
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim ws As Worksheet
On Error Resume Next
Worksheets("CALENDAR").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
r = 2 ' first row with appointment data in the active worksheet
Dim mysub, myStart, myEnd
While Len(Cells(r, 2).Text) <> 0
'mysub = Cells(r, 2) & ", " & Cells(r, 3)
'myStart = DateValue(Cells(r, 2).Value) + Cells(r, 3).Value
'myEnd = DateValue(Cells(r, 2).Value) + Cells(r, 4).Value
myStart = Cells(r, 3).Value
myEnd = Cells(r, 4).Value
Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
With olAppItem
' set default appointment values
.Location = Cells(r, 7)
.Body = ""
.ReminderSet = True
.BusyStatus = olFree
On Error Resume Next
.Start = myStart
.End = myEnd
.Subject = Cells(r, 6) 'INSTALL - Address'
.Location = Cells(r, 7).Value & " (" & Cells(r, 14).Value & ")"
.Body = .Subject & ", " & Cells(r, 8).Value & ", " & Cells(r, 9).Value & ", " & Cells(r, 10).Value & ", " & Cells(r, 11).Value & ", " & Cells(r, 12).Value & ", " & Cells(r, 13).Value
.ReminderSet = True
.BusyStatus = olBusy
On Error GoTo 0
.Save ' saves the new appointment to the default folder
End With
r = r + 1
Wend
Set olAppItem = Nothing
Set olApp = Nothing
MsgBox "Done !"
End Sub
Basically, I want to run the macro every day, and if the "body" of the calendar item exists, I want to update (overwrite it). If it's not there, I want to add it.
But I am also looking to be able to delete the calendar entry and I have spent hours looking for this! Can anyone please help me with this?
Bookmarks