Create Appt in Outlook VBA to Sharepoint Folder from Excel

I am trying to create appointments from Excel into a sharepoint calendar from Excel, i can successfully have appt's created but i have tried multiple ways to actually get to the sharepoint folder and it is not working. Here is my code, any suggestions on how to get it to work?

the sharepoint addres is \\SharePoint Lists\Car - MW Activity Calendar

Sub AddToOutlookgood()
'!! Reference to Outlook object library required !!
    Dim olAppointment As Outlook.AppointmentItem
    Dim olApptSearch As Outlook.AppointmentItem
    Dim olApp As Outlook.Application
    Dim olFolder As Outlook.Folder
    
    Dim lngRow As Long, shtSource As Worksheet
    Dim NS As Outlook.Namespace
    Dim colItems As Outlook.Items
    Dim Appfound As Boolean
    Dim UseDate As Date
    'Get reference to MS Outlook
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
    End If
 
    Dim MyCal As String
    MyCal = "Carolinas Operations & Maintenance - Maintenance Window Activity Calendar"   ' change your calendar name here
    Set NS = olApp.GetNamespace("MAPI")
    Set olFolder = NS.GetDefaultFolder(olFolderCalendar)
    On Error Resume Next
    Set olFolder = olFolder.Folders(MyCal)
    On Error GoTo 0
    Set shtSource = ActiveSheet
    For lngRow = 2 To shtSource.Cells(Rows.Count, 6).End(xlUp).Row
        Appfound = False
        Set olAppointment = olFolder.Items.Add
        UseDate = shtSource.Cells(lngRow, 6).Value
        With olAppointment
            .Subject = "WO" & shtSource.Cells(lngRow, 1) & " by " & shtSource.Cells(lngRow, 6)
            .Start = UseDate
            .AllDayEvent = True
            .Body = "The Domain " & shtSource.Cells(lngRow, 1) & " is NOT set to auto-renew. Renew before " & shtSource.Cells(lngRow, 6) & vbNewLine & vbNewLine & "Notes:" & vbNewLine & shtSource.Cells(lngRow, 7) & vbNewLine & vbNewLine & "Website:" & vbNewLine & shtSource.Cells(lngRow, 3)
            .Duration = 100
            .ReminderMinutesBeforeStart = 10080
            .ReminderSet = True
            Set colItems = olFolder.Items
            For Each olApptSearch In colItems
                If olApptSearch = olAppointment Then Appfound = True
            Next
            If Appfound = False Then
                .Save
            Else
                MsgBox "Appointment '" & .Subject & "' already exists. Not saved."
            End If
        End With
        Set olAppointment = Nothing
    Next lngRow
End Sub