Sorry to hear that, Alberta will get hit hard in the coming year. I hope this will do the trick for you, at least get you started. What I did was that I took your layout and pasted to column A
Sub CreateAppointments()
Dim objOutlook As Object
Dim objNamespace As Object
Dim objAppointment As Object
Dim lRow As Long
Dim LastRow As Long
Dim WSAppointments As Worksheet
Dim Appointment As Long
Dim FutureDays As Variant
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set WSAppointments = Worksheets("Sheet1")
Const olAppointmentItem = 1
LastRow = FindLastRow(WSAppointments, "A")
FutureDays = Array(0, 90, 180, 365, 545, 730)
For lRow = 2 To LastRow
For Appointment = 1 To 6
Set objAppointment = objOutlook.CreateItem(olAppointmentItem)
With objAppointment
.Start = DateAdd("d", FutureDays(Appointment - 1), _
Month(WSAppointments.Cells(lRow, "B")) & "/" & _
Day(WSAppointments.Cells(lRow, "B")) & "/" & _
Year(WSAppointments.Cells(lRow, "B")) & " 09:00 AM" _
)
.Duration = 30
.Subject = WSAppointments.Cells(lRow, "A")
.Body = WSAppointments.Cells(lRow, "I")
.Location = WSAppointments.Cells(lRow, "A")
.ReminderMinutesBeforeStart = 30240
.ReminderSet = True
.Save
End With
Next Appointment
Next lRow
Set objOutlook = Nothing
Set objNamespace = Nothing
Set WSAppointments = Nothing
End Sub
Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
' This function will fine the last row based on the Column that is sent to it.
FindLastRow = WS.Range(ColumnLetter & Rows.Count).End(xlUp).Row
End Function