Using a VBA macro to post new appointments in outlook, but don't want duplicates

[Crixx316]

Good Afternoon,

I'm hoping that you can help me out as I'm very new to VBA.

I managed to create a VBA macro after looking online which creates appointments in my outlok calendar, but the problem is that the appointments are duplicated everytime I run the macro (which is quite frequent).

My original code was:

Sub AddAppointments()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
' Start at row 2
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
' Create the AppointmentItem
Set myApt = myOutlook.createitem(1)
' Set the appointment properties
myApt.Subject = Cells(r, 1).Value
myApt.Location = Cells(r, 2).Value
myApt.Start = Cells(r, 3).Value
myApt.Duration = Cells(r, 4).Value
' If Busy Status is not specified, default to 2 (Busy)
If Trim(Cells(r, 5).Value) = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Cells(r, 5).Value
End If
If Cells(r, 6).Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
Else
myApt.ReminderSet = False
End If
myApt.Body = Cells(r, 7).Value
myApt.Save
r = r + 1
Loop
End Sub


I then tried to edit the VBA macro to search my outlook calendar for appointments already there with the same date/time and subject field. However no matter how much I try to edit it, I just can't get it working. My new code is:

Sub AddAppointmentsTest()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
' Start at row 2
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
If o1Appointment.Start = Cells(r, 3) And _
o1Appointment.Subject = Cells(r, 1) Then
r = r + 1
Else
' Create the AppointmentItem
Set myApt = myOutlook.createitem(1)
' Set the appointment properties
myApt.Subject = Cells(r, 1).Value
myApt.Location = Cells(r, 2).Value
myApt.Start = Cells(r, 3).Value
myApt.Duration = Cells(r, 4).Value
' If Busy Status is not specified, default to 2 (Busy)
If Trim(Cells(r, 5).Value) = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Cells(r, 5).Value
End If
If Cells(r, 6).Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
Else
myApt.ReminderSet = False
End If
myApt.Body = Cells(r, 7).Value
myApt.Save
r = r + 1
End If
Loop
End Sub

I've highlighted in red the bits that I've added. Cell (r, 3) in my spreadsheet denotes the start time, and Cell (r, 1) denotes the subject.

Could someone experienced please try and help me out as it's driving me crazy now.

Thanks in advance for any assistance that anyone is able to provide.

Regards,

 

[John_w]

Your code is hard to follow without indentation - please use CODE tags. What is o1Appointment? Is it declared (Dim statement) in the code? Where do you assign it? Add Option Explicit at the top of the module and declare all variables.

Try something like the following code which determines if an appointment with a specific subject already exists.

Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem

    Dim olCalendarItems As Outlook.Items
    Dim subjectFilter As String
    
    'Get calendar items with the specified subject
        
    subjectFilter = "[Subject] = '" & subject & "'"
    Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)
    
    If olCalendarItems.Count > 0 Then
        Set Get_Appointment = olCalendarItems.Item(1)
    Else
        Set Get_Appointment = Nothing
    End If
    
End Function

If the appointment exists it returns the first matching appointment, otherwise Nothing. It should be fairly easy to include a date-time in the filter - look at the Outlook help on Filter. The code uses early binding of Outlook objects so you'll need to set a reference to the Outlook library in Tools - References in your VBA project.