Hey Guys,
I'm stuck trying to prevent duplicate appointments being created when i run the following code to import excel dates to outlook.
I need the code to ignore subject, start and body entries that match existing appointments in my calendar.
Here is a sample of my workbook that the code currently creates appointments from.
I'm stuck trying to prevent duplicate appointments being created when i run the following code to import excel dates to outlook.
VBA Code:
Public Sub CreateOutlookMeetings()
Sheets("sheet1").Select
On Error GoTo Err_Execute
Dim olApp As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As Outlook.Namespace
Dim CalFolder As Outlook.MAPIFolder
Dim i As Long
On Error Resume Next
Set olApp = Outlook.Application
If olApp Is Nothing Then
Set olApp = Outlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
' get the start date
Dim startDate As Date
startDate = Cells(i, 3).Value
' get the recipients
Dim theRecipients As String
theRecipients = Cells(i, 7).Value
' check whether the start date is today or later, and whether recipients exist
If startDate >= Date And Len(theRecipients) > 0 Then
Set olAppt = CalFolder.Items.Add(olAppointmentItem)
With olAppt
.MeetingStatus = olMeeting
'Define calendar item properties
.Subject = Cells(i, 1) + Cells(i, 2)
.Start = Cells(i, 4)
.Categories = Cells(i, 5)
.Body = Cells(i, 6)
.AllDayEvent = True
.BusyStatus = olFree
.ReminderMinutesBeforeStart = 2880
.ReminderSet = True
' get the recipients
Dim RequiredAttendee As Outlook.Recipient
Set RequiredAttendee = .Recipients.Add(theRecipients)
RequiredAttendee.Type = olRequired
.Display
End With
End If
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub
I need the code to ignore subject, start and body entries that match existing appointments in my calendar.
Here is a sample of my workbook that the code currently creates appointments from.