Change appointments in excel but not duplicate in outlook

[Masterkale]

Hello i am trying to build an orderlist with some planned maintenance jobs. When the list is updated i want them to copy them to outlook calendar so the guys can see what kind of work they have to do.

But .... The start date of the orders are sometimes changed. So when i shoot them into outlook they will duplicate but on a different date. Now i got 2 buttons 1: to shoot the orders into outlook and button2: To delete duplicate orders on other startdates, but it will delete the good planned order and keeps the wrong one (older one).
I am a total noob with VBA so please tell me step by step what to do to solve this.

thank you

Private Sub CommandButton21_Click()

' 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, 2).Value
        myApt.Location = Cells(r, 3).Value
        myApt.Start = Cells(r, 4).Value
        myApt.Duration = Cells(r, 5).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 7).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 7).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, 1).Value
        myApt.Save
        r = r + 1
    Loop
    
    MsgBox "De orders zijn naar outlook gekopieerd."

End Sub

Private Sub CommandButton22_Click()
' Delete duplicate appointments

Const olFolderCalendar = 9

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
Set myItems = myFolder.Items

'Sort the calendar database
Dim strTri
strTri = ""
strTri = strTri & "[Start]"
strTri = strTri & "[End]"
strTri = strTri & "[Subject]"
strTri = strTri & "[Body]"
strTri = strTri & "[AllDayEvent]"
strTri = strTri & "[Sensitivity]"

myItems.Sort strTri

'Delete successive equal appointments

Dim lastStr, Str, nbrDelete
lastStr = ""

nbrDelete = 0
For Each Item In myItems

Str = ""
Str = Str & vbCrLf & Item.Subject
Str = Str & vbCrLf & Item.Body
Str = Str & vbCrLf & Item.AllDayEvent
Str = Str & vbCrLf & Item.Sensitivity

Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)
Str = Replace(Str, vbCrLf & vbCrLf, vbCrLf)

If Str = lastStr Then
Item.Delete
nbrDelete = nbrDelete + 1
End If
lastStr = Str
Next

MsgBox "Dubbele orders gewist. : " & nbrDelete

End Sub

 

[Masterkale]

I modified my marco a little
added this to the module

Public Function CheckAppointment(ByVal argCheckDate As Date) As Boolean
 
  Dim oApp As Outlook.Application
  Dim oNameSpace As Outlook.Namespace
  Dim oApptItem As Outlook.AppointmentItem
  Dim oFolder As Outlook.MAPIFolder
  Dim oMeetingoApptItem As Outlook.MeetingItem
  Dim oObject As Object
  
  On Error Resume Next
  ' check if Outlook is running
  Set oApp = GetObject("Outlook.Application")
  If Err <> 0 Then
    'if not running, start it
    Set oApp = CreateObject("Outlook.Application")
  End If
  
  Set oNameSpace = oApp.GetNamespace("MAPI")
  Set oFolder = oNameSpace.GetDefaultFolder(olFolderCalendar)
  
  CheckAppointment = False
  For Each oObject In oFolder.Items
    If oObject.Class = olAppointment Then
      Set oApptItem = oObject
      If oApptItem.Start = argCheckDate Then
        CheckAppointment = True
      End If
    End If
  Next oObject
    
  Set oApp = Nothing
  Set oNameSpace = Nothing
  Set oApptItem = Nothing
  Set oFolder = Nothing
  Set oObject = Nothing
   
End Function

Private Sub CommandButton21_Click()

' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")
    ' Start at row 2
    r = 2
    Do Until Trim(Cells(r, 1).Value) = ""
    
    If CheckAppointment(Cells(r, 1)) = False Then
    
        ' Create the AppointmentItem
        Set myApt = myOutlook.CreateItem(1)
        ' Set the appointment properties
        myApt.subject = Cells(r, 2).Value
        myApt.Location = Cells(r, 3).Value
        myApt.Start = Cells(r, 4).Value
        myApt.Duration = Cells(r, 5).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 7).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 7).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, 1).Value
        myApt.Save
        End If
    
        r = r + 1
    Loop
End Sub

It still import dubble appointments