Excel to Outlook Calendar as Appointments - Delete Duplicate Entries

[Bwiles96]

Afternoon everyone,

I have a functioning macro to take a table from excel and make appointments in calendars based on the date and time of each line of said table.

However, I am in need of a better code to search the outlook calendar and delete duplicated entries.

For example, if i have an appointment on July 13th at 8:00 am and the time/date moves to July 14th at 9:00 am, both entries will still exist.

Can anyone help tweak my code to delete duplicate outlook calendar entries from a excel vba document?

Sub SWABulk()
    Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
    r As Long, i As Long, WB As ThisWorkbook

    Set WB = ThisWorkbook
    Set ES = Sheets("SWA")
    r = ES.Cells(Rows.Count, 1).End(xlUp).Row
    Set OL = New Outlook.Application
Dim oApp As Object
Dim oNameSpace As Namespace
Dim oFolder As Object
 
Set oApp = New Outlook.Application
Set oNameSpace = oApp.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("00000000D2445828F4789E44A111E6A22882CE33010002A6B5E8D83D81409505CFA3036FFB94000034F6F9C70000")
For i = 1 To r
    If ES.Cells(i, 17) = "Bulk" And ES.Cells(i, 17).Font.Color = RGB(255, 0, 0) Then
    Set Appoint = OL.CreateItem(olAppointmentItem)
    With Appoint
        .Subject = ES.Cells(i, 1).Value
        .ReminderSet = False
        .Start = ES.Cells(i, 19).Value
        .Duration = 60
        .Location = ES.Cells(i, 18).Value
        .AllDayEvent = False
        .Categories = .Categories & "Bulk Loads;Credit Hold"
        .Body = ES.Cells(i, 16).Value
        .Save
        .Move oFolder
    End With
    
    
    End If
       If ES.Cells(i, 17).Value = "Bulk" And ES.Cells(i, 17).Font.Color = RGB(0, 0, 0) Then
    Set Appoint = OL.CreateItem(olAppointmentItem)
    With Appoint
        .Subject = ES.Cells(i, 1).Value
        .ReminderSet = False
        .Start = ES.Cells(i, 19).Value
        .Duration = 60
        .Location = ES.Cells(i, 18).Value
        .AllDayEvent = False
        .Categories = .Categories & "Bulk Loads"
        .Body = ES.Cells(i, 16).Value
        .Save
        .Move oFolder
    End With
    
    End If
Next i
 Set OL = Nothing

End Sub

Sub SWADeleteDuplicates()

Dim lngCnt As Long
Dim objMail As Object
Dim objFSO As Object
Dim objTF As Object

Dim objDic As Object
Dim objItem As Object
Dim olApp As Outlook.Application
Dim olNS As Namespace
Dim olFolder As Folder
Dim olFolder2 As Folder
Dim strCheck As String

Const strPath = "c:\temp\deleted msg.csv"

Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.CreateTextFile(strPath)
objTF.WriteLine "Subject"

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(olFolderCalendar)
Set olFolder = olFolder.Folders("SWA")

If olFolder Is Nothing Then Exit Sub

On Error Resume Next
Set olFolder2 = olFolder.Folders("Duplicates")
On Error GoTo 0

If olFolder2 Is Nothing Then Set olFolder2 = olFolder.Folders.Add("Duplicates")


For lngCnt = olFolder.Items.Count To 1 Step -1

Set objItem = olFolder.Items(lngCnt)

strCheck = objItem.Subject & "," & objItem.Body & "," & objItem.Start & "," & "," & objItem.Location & ","
strCheck = Replace(strCheck, ", ", Chr(32))

    If objDic.Exists(strCheck) Then
       objItem.Delete
    Else
        objDic.Add strCheck, True
    End If
Next

End Sub