Outlook appointments being overwritten when created from Excel loop - excel

Question

I loop through information in an Excel sheet to create appointments in Outlook. It was working when I sent it to my default folder.
I made changes to upload the data to a specific folder (shared by coworkers).
Since then, as I F8 through my code, it saves the appointment for the row being looped through. However, when I go to the next row, the new appointment replaces the old instead of both being saved.
Sub ExportToOutlook
Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _
r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count,1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("Insert the ID").Items.Add(olAppointmentItem)
For i = 2 to r
With oFolder
.Subject = ES.Cells(i,1).Value
.Start = ES.Cells(i,2).Value
.End = ES.Cells(i,3).Value
.Location = ES.Cells(i,4).Value
.AllDayEvent = ES.Cells(i,5).Value
.Categories = ES.Cells(i,6).Value & " Category"
.Save
End With
Next i
Set OL = Nothing
End Sub

Answer 1

You seem to be reupdating the same folder at each row iteration. Try the following:
Sub ExportToOutlook
Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _
r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count,1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("Insert the ID")
For i = 2 to r
Dim appt as MailItem
Set appt = oFolder.Items.Add(olAppointmentItem)
With appt
.Subject = ES.Cells(i,1).Value
.Start = ES.Cells(i,2).Value
.End = ES.Cells(i,3).Value
.Location = ES.Cells(i,4).Value
.AllDayEvent = ES.Cells(i,5).Value
.Categories = ES.Cells(i,6).Value & " Category"
.Save
End With
Next i
Set OL = Nothing
End Sub

Answer 2

Dim appt as Outlook.AppointmentItem was the fix for me!
Sub ExportToOutlook2()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook, oFolder As Object, oNameSpace As Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count, 1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("00000000579E67EAD9C2C94591E62A3CF21135F801001241364BFDA9AF49A3D3384A976997C50036FCD700060000")
For i = 2 To r
Dim appt As Outlook.AppointmentItem
Set appt = oFolder.Items.Add(olAppointmentItem)
With appt
.Subject = ES.Cells(i, 1).Value
.Start = ES.Cells(i, 2).Value
.End = ES.Cells(i, 3).Value
.Location = ES.Cells(i, 4).Value
.AllDayEvent = ES.Cells(i, 5).Value
.Categories = ES.Cells(i, 6).Value
.Save
End With
Next i
Set OL = Nothing
End Sub