从Excel工作表导入Outlook日历时，VBA宏会重复条目

Question

我的Excel VBA代码将团队休假日历导出到Outlook。当我重新运行它时，将创建重复项。如何确保仅导出新更改，并避免工作表中所有单元格重复？

工作表有5列：Calendar, Last Name, First Name, Start Date, End Date

Public Sub CreateOutlookApptz()
    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 subFolder As Outlook.MAPIFolder
    Dim arrCal As String
    Dim oWS As Worksheet
    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) = ""
        arrCal = Cells(i, 1).Value
        Set subFolder = CalFolder.Folders(arrCal)
        If Trim(Cells(i, 11).Value) = "" Then
            Set olAppt = subFolder.Items.Add(olAppointmentItem)

            'MsgBox subFolder, vbOKCancel, "Folder Name"
            Set oWS = Sheet1
            With olAppt
                'Define calendar item properties
                .Start = Cells(i, 4) + TimeValue("00:00:01")
                .End = Cells(i, 5) + TimeValue("23:59:59")
                .Subject = oWS.Cells(i, 2) + " " + oWS.Cells(i, 3) + " Vacation"
                .ReminderSet = True
                .Save
            End With
            Cells(i, 6) = "Imported"
        End If
        i = i + 1
    Loop
    Set olAppt = Nothing
    Set olApp = Nothing
    ThisWorkbook.Save
    Exit Sub

Err_Execute:
    MsgBox "An error occurred - Exporting items to Calendar."

End Sub