Trouble creating outlook event from

Hi Nick

Replace the Code with this...

Option Explicit
Sub AddOutLookTask()
   ' add a refrence to Microsoft outlook object library
   Dim appOutLook   As Outlook.Application
   Dim taskOutLook  As Outlook.AppointmentItem
   Dim myItem       As Outlook.AppointmentItem
   Dim myItems      As Outlook.Items
   Dim data         As Worksheet
   Dim subject      As String
   Dim body         As String
   Dim wen          As Date
   Dim i            As Long
   Dim olNs         As Namespace
   Dim durationarray() As String
   Dim Duration     As Double
   Dim reminder1()  As String
   Dim Reminder     As Double
   Dim myArray()    As Variant
   Dim msgString    As String

   ReDim myArray(0)
   Set appOutLook = CreateObject("Outlook.Application")
   Set olNs = appOutLook.GetNamespace("MAPI")
   Set myItems = olNs.GetDefaultFolder(olFolderCalendar).Items

   '   Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
   Set data = ThisWorkbook.Worksheets("Agenda")   ' change worksheetname as required
   For i = 2 To Application.CountA(Sheets("Agenda").Range("A:A"))   ' loop through each row starting at row 2  (loop uses column A as a count - ensure column A always contains a name
      subject = data.Cells(i, 1)
      body = "You have a meeting with " & subject
      wen = DateValue(data.Cells(i, 2)) + data.Cells(i, 3)
      If InStr(data.Cells(i, 4), "hr") Then   ' does duration contain 'hr'
         durationarray = Split(data.Cells(i, 4), " ")   ' get digits before first space
         Duration = Val(durationarray(0))
      Else
         durationarray = Split(data.Cells(i, 4), " ")
         Duration = Val(durationarray(0)) / 60   'if duration does not contain hr  (i.e. mins) then convert mins to decimal of an hour  (30 mins = 0.5)
      End If
      reminder1 = Split(data.Cells(i, 5), " ")   ' assume always days and get digits before first space
      Reminder = reminder1(0)

      '      ReDim myArray(0)
      Set myItem = myItems.Find("[Subject]=" & Chr(34) & subject & Chr(34))

      If Not myItem Is Nothing Then
         If myItem.subject = subject And _
            myItem.Duration / 60 = Duration And _
            myItem.Start = wen Then

            myArray(UBound(myArray)) = subject & " already acheduled"
            ReDim Preserve myArray(UBound(myArray) + 1)
            '            MsgBox subject & " Already Scheduled"
            GoTo Skip_Me
         End If

      Else
         Set taskOutLook = appOutLook.CreateItem(olAppointmentItem)
         With taskOutLook
            .subject = subject
            .body = body
            .ReminderSet = True
            .ReminderMinutesBeforeStart = Reminder * 24 * 60   ' reminder in hours converted to minutes
            .Duration = Duration * 60   ' duration converted to minutes
            .Start = wen   ' start date/time
            .Save
         End With
      End If
      Set myItem = myItems.FindNext
Skip_Me:
   Next
   On Error Resume Next
   ReDim Preserve myArray(UBound(myArray) - 1)
   On Error GoTo 0
   msgString = Join(myArray, vbCr)
   If Not IsError(Application.Match("*", (myArray), 0)) Then
      MsgBox msgString
   End If
   Set appOutLook = Nothing
   Set taskOutLook = Nothing
   Set data = Nothing
   Set taskOutLook = Nothing
End Sub