Having trouble posting Appointments to (non default) Outlook Calendar using VBA

[Raustin]

Have spent a considerable amount of time trying to get my appointment information, from Excel, to post into a non-default Calendar (folder). I have also tried to research this issue a lot, but no workable solution. I used some code to get the folder ID, which works great, and i can get the appointments to post to the default folder, which also works fine. The following code will post to the non-default folder, however, only the last appointment created is saved, while the previous one is just erased when then next one is entered. Any and all help would be greatly appreciated. The Code is as follows:

Private Sub SyncCal_Click()Dim CRow As Long
Dim CCol As Long
Dim ADur As Long
Dim ASubject As String
Dim CDat As Long
Dim AStart As String
Dim FoldNm As String


    Dim olApp As Outlook.Application
    Dim NS As Namespace
    Dim olApt As Outlook.AppointmentItem
    Dim olFldr As Object
    
     'Get reference to MS Outlook
    On Error Resume Next
    Set olApp = New Outlook.Application
                                     
    FoldNm = Range("A1").Value
    Set NS = olApp.GetNamespace("MAPI")
    'I used some other VBA i found to get the Folder ID, which is correct.
    Set olFldr = NS.GetFolderFromID("0000000072DF884F27EEC849A78F78FDD6F4C183E2850000").Items.Add(olAppointmentItem)


'Goes through my worksheet to get Appointment Date, Time and Subject
For CRow = 4 To 36
  For CCol = 3 To 42 Step 2
  
 Set olApt = olApp.CreateItem(olAppointmentItem)


 
 With olFldr
  ' Using " With olApt " i can get all the appointments to Default Calendar 
        CDat = Cells(CRow, 2).Value
            'Add appointment only if cell contains data, otherwise skip
            If Cells(CRow, CCol).Value <> "" Then
              AStart = Sheet5.Cells(CRow, 2) + Sheet5.Cells(3, CCol)
               
                
                    .Subject = Sheet5.Cells(CRow, CCol + 1).Value
                    .Start = AStart
                    .Duration = Sheet5.Cells(CRow, CCol)
                    .ReminderSet = False
                    .Categories = "TestAppointment"
                    .Save
             End If
    End With
    Next CCol
Next CRow
Set olApp = Nothing
End Sub