Excel dates to Outlook

Sub SetAppt()

Dim olApp As Object
'    Dim olApp As Outlook.Application
Dim olApt As Object
Dim olNs As Object

' The following routine displays the calendar, opening OL if needed
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")

    If Err.Number = 429 Then
        Set olApp = CreateObject("Outlook.application")
    End If

    On Error GoTo 0

    Set olNs = olApp.GetNamespace("MAPI")

    If olApp.ActiveExplorer Is Nothing Then
        olApp.Explorers.Add _
            (olNs.GetDefaultFolder(9), 0).Activate
    Else
        Set olApp.ActiveExplorer.CurrentFolder = _
            olNs.GetDefaultFolder(9)
        olApp.ActiveExplorer.Display
    End If

'    Set olApp = New Outlook.Application
    Set olApt = olApp.CreateItem(olAppointmentItem)
'  Gather the values to use in the appointment    
    usedate = Range("date_default").Value
    usesubject = Range("subject").Value
    

    With olApt
        .Start = usedate + TimeValue("9:00:00")
        .End = usedate + TimeValue("11:00:00")
        .Subject = usesubject
        .Location = usesubject & " location"
        .Body = "enter the text of your appointment here"
        .BusyStatus = olOutOfOffice
        .ReminderMinutesBeforeStart = 30
        .ReminderSet = True
        .Save
    End With
    
    olApt.Display
     
    Set olApt = Nothing
    Set olApp = Nothing
    Set olNs = Nothing
End Sub