PDA

View Full Version : [SOLVED] Excel generate Outlook appointments



nitey4ever
01-13-2015, 10:16 AM
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
01-13-2015, 12:47 PM
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