Hi, Im really struggling here.

I have this piece of code that adds dates to my Outlook Calendar. If all dates are added at once, and the code is run then its fine, however staff need to input dates as and when. The code runs again and adds duplicate dates to outlook. Can anyone suggest a workaround that overwrites existing dates and only adds new ones.

I also found another problem. When A date is added ie 01/03/2016 it adds an entry to my calendar. However there are 484 rows and a calendar entry is added for all the blank rows as well, with a date of Sat 30/12/1899. How can I only add dates to the calendar and ignore at any blank cells.

Private Sub CommandButton1_Click()
If Not ThisWorkbook.Name = "LD TOOL v3.xlsm" Then
' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")

    ' Start at row 5
    r = 6
Application.ScreenUpdating = False
    Do Until Trim(Cells(r, 1).Value) = ""
        If Cells(r, 9).Value <> "" Then
            ' Create the AppointmentItem
            Set myApt = myOutlook.createitem(1)
            ' Set the appointment properties
            myApt.Subject = Cells(r, 1).Value
            myApt.Start = Cells(r, 9).Value
            myApt.Location = Cells(r, 10).Value
            myApt.Duration = Cells(r, 11).Value
            ' If Busy Status is not specified, default to 2 (Busy)
            If Trim(Cells(r, 12).Value) = "" Then
                myApt.BusyStatus = 2
            Else
                myApt.BusyStatus = Cells(r, 12).Value
            End If
            If Cells(r, 13).Value > 0 Then
                myApt.ReminderSet = True
                myApt.ReminderMinutesBeforeStart = Cells(r, 13).Value
            Else
                myApt.ReminderSet = False
            End If
            myApt.Body = Cells(r, 14).Value
            myApt.Save
            End If
            r = r + 1
          'Cells(r, 9).Value <> ""
    Loop    'Trim(Cells(r, 1).Value) = ""
    Application.ScreenUpdating = True
End If
End Sub