Excel generate Outlook appointments

[nitey4ever]

I am on a bit of a time crunch as I have been laid off from my current position with 2 weeks notice. I am trying to set up something quickly to assist those that are left to do my work.

Based on the scripts at [Solved] Excel generate calendar appointments in Outlook, post #20 (sorry, newbie, can't post links), I was hoping someone may be able to help me out.

I do have experience with coding, but it is from almost 15 years ago now.

As with everyone who needs help, *I* think what I need is simple. Based on the data in this table (more rows in my worksheet, I'm just giving you the example):

Address	Possession	Warranty Ends	Name	Email Address	Reno Done	Last Contact Made	Next Contact Due	Notes
110 Lakeview	10/9/2014	10/8/2016	Joe Smith	email address	kitchen	na	1/7/2015

I would like to set up 6 all-day appointments in Outlook:
Possession Date (as above)
Possession Date + 90 days
Possession Date + 180 days
Possession Date + 365 days
Possession Date + 545 days
Possession Date + 730 days

The appointments only need the address as the Subject, a 3-week reminder (ReminderMinutesBeforeStart = 30240), and the Notes column as the Body.

Then it obviously needs to not create duplicate appointments.

If anyone could assist me with this (and getting it running properly) it would be greatly appreciated (and possibly worth a beer fund donation?)!

[JKwan]

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