Outlook's recurring patterns leave a lot to be desired. The available recurring patterns are limited and support just one pattern per event: every other Thursday, every third Thursday etc, not the first and third Thursday or second Monday after the first Wednesday.
While it's often better to create 2 recurring appointments for patterns such as first and third Thursdays (one for the first event each month and one for the second), you can use VBA to create individual events in more flexible patterns such as the third Tuesday after the first Thursday.
This code takes the subject, start time, location, and duration from the selected or open appointment and creates a series of individual appointments for the first Monday and a second one xx days later in each month for xx months.
To use a different day of the week or a different week, adjust the pdtdate in the macro. (Or, edit the function.)
The next Friday is pdtmdate = Format(pdtmdate + 4, "MM/dd/yyyy")
Third Monday is pdtmdate = Format(pdtmdate + 14, "MM/dd/yyyy")
The date for the second appointment is calculated off of the first appointment:
objAppt3.Start = objAppt2.Start + 14
If you only need one appointment per month, delete the block of code used to create the second appointment.
Raymond wrote a more complex macro to set multiple appointments and checks for holidays too. His version of the macro is here.
Public Sub CreatePatternsAppointmentSeries()
Dim objAppt As Outlook.AppointmentItem
Dim objAppt2 As Outlook.AppointmentItem
Dim objAppt3 As Outlook.AppointmentItem
Dim NumOfDays As Long
Dim Offset As Long
Dim NumAppt As Long
Dim nextAppt 'As Date
Set objAppt = GetCurrentItem()
If TypeName(objAppt) = "AppointmentItem" Then
pdtmdate = InputBox("Enter beginning month and year in mm/yyyy format", _
"First month of series", Format(Now, "mm/yyyy"))
NumAppt = InputBox("How many months in the series? (2 appointments per month)")
Offset = InputBox("How days is the second appointment offset from the first?")
'change this line for other dates
pdtmdate = FirstMondayofMonth(Format(pdtmdate, "MM/dd/yyyy"))
For x = 1 To NumAppt
Set objAppt2 = Application.CreateItem(olAppointmentItem)
' calculate other dates in this line, "pdtmdate +14,"
pdtmdate = Format(pdtmdate, "MM/dd/yyyy")
With objAppt
' I'm using a limited number of fields, you can
' add others.
objAppt2.Subject = .Subject
objAppt2.Location = .Location
objAppt2.Body = .Body
objAppt2.Start = Format(pdtmdate, "MM/dd/yyyy") & _
" " & Format(objAppt.Start, "hh:mm AMPM")
objAppt2.Duration = .Duration
objAppt2.Categories = .Categories
End With
On Error Resume Next
objAppt2.Save
' create the second appointment
Set objAppt3 = Application.CreateItem(olAppointmentItem)
With objAppt
objAppt3.Subject = .Subject
objAppt3.Location = .Location
objAppt3.Body = .Body
objAppt3.Start = objAppt2.Start + Offset
objAppt3.Duration = .Duration
objAppt3.Categories = .Categories
End With
On Error Resume Next
objAppt3.Save
' Get the next month before looping back through
If Format(pdtmdate, "mm") < 12 Then
pdtmdate = Format(pdtmdate, "mm") + 1 & "/" & Format(pdtmdate, "yyyy")
Else
pdtmdate = Format("1/1/2009", "mm") & "/" & (Format(pdtmdate, "yyyy") + 1)
End If
pdtmdate = FirstMondayofMonth(Format(pdtmdate, "MM/dd/yyyy"))
Next x
End If
Set objAppt = Nothing
Set objAppt2 = Nothing
Set objAppt3 = Nothing
End Sub
Function FirstMondayofMonth(pdtmdate As Date) As Date
Dim dtmFirstOfMonth As Date
dtmFirstOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate), 1)
Select Case Weekday(dtmFirstOfMonth)
Case vbMonday: FirstMondayofMonth = dtmFirstOfMonth
Case vbTuesday: FirstMondayofMonth = dtmFirstOfMonth + 6
Case vbWednesday: FirstMondayofMonth = dtmFirstOfMonth + 5
Case vbThursday: FirstMondayofMonth = dtmFirstOfMonth + 4
Case vbFriday: FirstMondayofMonth = dtmFirstOfMonth + 3
Case vbSaturday: FirstMondayofMonth = dtmFirstOfMonth + 2
Case vbSunday: FirstMondayofMonth = dtmFirstOfMonth + 1
End Select
End Function
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Count back from the end of the month
To get the last day of the month we use the code above, replacing the FirstMondayofMonth function to count from the end of the month instead.
You'll also need to subtract from the date line:
pdtmdate = LastDayofMonth(Format(pdtmdate - 4, "MM/dd/yyyy"))
To use this function with the code above, change FirstMondayofMonth to LastMondayofMonth in this line (it's used twice).
pdtmdate = FirstMondayofMonth(Format(pdtmdate, "MM/dd/yyyy"))
Function LastMondayofMonth(pdtmdate As Date) As Date
Dim dtmLastOfMonth As Date
dtmLastOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate) + 1, 0)
Select Case Weekday(dtmLastOfMonth)
Case vbMonday: LastMondayofMonth = dtmLastOfMonth
Case vbTuesday: LastMondayofMonth = dtmLastOfMonth - 1
Case vbWednesday: LastMondayofMonth = dtmLastOfMonth - 2
Case vbThursday: LastMondayofMonth = dtmLastOfMonth - 3
Case vbFriday: LastMondayofMonth = dtmLastOfMonth - 4
Case vbSaturday: LastMondayofMonth = dtmLastOfMonth - 5
Case vbSunday: LastMondayofMonth = dtmLastOfMonth - 6
End Select
End Function
Carlo M Merhi says
I would be forever in your debt if you can figure out how to make this pattern happen. I got close but not on the Grey and Black and not without having 3 different VBAs, one for each set.
Yellow - 2nd Tuesday of the month
Blue - 1st Friday after Yellow
Orange - 3rd Tuesday of the month
Red - 1st Wed after Orange
Grey - 1st Tuesday of the month
Black - 1st Friday before Grey
If any of the dates (except Yellow) falls on a Holiday, pick the day before if it is a weekday else the first day after holiday if it is a weekday.
Pete Motley says
Or, create appointments in new Google calendar, export to ics file and import into Outlook
Diane Poremsky says
to make a weird recurring pattern?
Darren says
Would it be possible to create a recurring calendar event that excludes ever other Wednesday, after the creation of the event?
Diane Poremsky says
to make a truly recurring event, you'd need to set exceptions. The macro on this page creates individual events - it could create the pattern you want if you calculate the pattern correctly.
jarvis says
Hello. Thanks for the code.
Is there a way to get the appts to use the reoccurrence feature so they can be edited at one time?
For example, if I use your script to creatre my appts they look to be separate. So if I want to update my invitee list, or the subject I will have to do it for each individual appt. Any way to do this through one edite rather than multiple edits?
Thank you.
Diane Poremsky says
you can use a script to create recurring appointments that are in one of outlook's patterns, it could do the exceptions too, but too many exceptions tend to corrupt it. Individual events (what this script does) are definitely better for appointments but more annoying for meetings. I don't think i have any example code that creates recurring with exceptions, but will check.
ritzymitzy says
Sweet! Macro totally works. Thanks so much, Diane!
victor abraham says
Hello to all. I a physician with no programming experience. I am charged of creating the call schedule for the urologists in my town , using outlook calendar. We define the working week as all day long Monday through Thursday and the weekend call schedule as Friday, Sat and Sunday till 7 am Monday. Creating the weekend recurrent call schedule is easy. The weekdays, as every 9 weekdays is only possible creating a round of 9 days and then cutting and pasting.
Has anyone encountered this issue? and more importantly a solution to it
Thanks in advance!
Victor
Diane Poremsky says
Everyone encounters it, unfortunately, there is no easy solution. Copy, paste, and change the date should work... it might be a little easier although the same amount of work. Create the first, copy it, move the copy to the date it belongs on then edit as needed.
Chris says
This is great! I'm having an issue with the number of months though. I've set 13 appointments for January based around the LastMondayofMonth code, which all work perfectly. However, if I attempt to run the code for more than 1 month I simply get 2 January appointments? I've checked my code to see if I've input an actual date somewhere by mistake but I haven't.
Diane Poremsky says
It's been a few years since I last tried it so my memory is fuzzy, but I seem to recall it was a bit goofy, so my guess is that the problem is with the code, not you.
Adrie Rijnen says
If you want to get any day use
DateFirstOfMonth = DateSerial(Year(InDate), Month(InDate), 1)
DaysAfterFirstOfMonth = InDay - Weekday(DateFirstOfMonth)
If DaysAfterFirstOfMonth >= 7 Then DaysAfterFirstOfMonth = DaysAfterFirstOfMonth - 7
If DaysAfterFirstOfMonth < 0 Then DaysAfterFirstOfMonth = DaysAfterFirstOfMonth + 7
for InDay I use vbMonday,vbTuesday etc. You can even use a form to let the user select the day and transform it into a long
bhim says
Thanks Diane.....the only option i had is to create two seperate appointmnts.But i would be watching this space to see if i can get relevant post and code for a single appointment for the same...thanks again
bhim says
H Diane , i am looking for a single recurrent appointment which occurs every thursday for 2 hours but on every 2nd thursday it should be only one hour.As i am not a programmer, i think i need help here. this must be the simplest of all the questions above but i need help.
Diane Poremsky says
You need to make 2 (or more) recurring appointments - one for the second tuesday and one (or more) for all of the other thursdays. Or you can adjust the time of the second tuesday as they come up (or go through the calendar month by month and adjust it well into the future.)
Being the lazy sort, I'd put a note in the Notes field and adjust it as they came on the screen. Most of my appointments are scheduled less than 30 days out, so it wouldn't affect my availability much.
This macro really won't help much - and would create individual appointments (you could use Excel and import a CSV to do that) - but if i get a chance, I will see if i can get it to work.
Fiona says
I have just migrated from Lotus Notes to Outlook 2013 and can't believe how complicated it is to produce custom meetings. Within Lotus Notes you clicked on repeat and then you could select custom, by selecting custom is brought up a calendar and you could click any date. So so simple, so why is Outlook so difficult!
Diane Poremsky says
There is (or was) and addin that could do it (by creating individual events, not recurrences), but yeah, this is one thing that Notes definitely did better.
Joe Campagna says
Thanks for the reply Diane, I'll go the "3rd" route. Response appreciated...
Joe Campagna says
Hi Diane, I need to set an event for every 3rd Friday of the month, but want that event to be present every weekday when the event is "current". Example, this Friday 5/16/2014 is the 3rd Friday, but I want the event to show in Outlook Monday through Friday of this week, so 5/12-5/16. Ideas outside of VBA?
Diane Poremsky says
You'll need to use VBA i think - or make individual events, for the 3rd mon, 3rd tues, 3rd wed, etc. (Yeah, I know, that won't work every time, but you can move the exceptions.)
kris says
Hi Diane,
I am sure you are doing great stuff and thank you for sharing this with us. I am struggling with Outlook 2012 to book recurring appointments for the 7th working day of every month, i need to do this for the whole year - 2014, any advice from you will be very helpful.
many thanks
Kris
Diane Poremsky says
It's not going to be a recurring because it's a pattern outlook doesn't support. You can create 12 individual appointments in Excel and import or use VBA. I have some macros that create appointments, like this one, but none that do exactly what you want.
Johan says
Hi Diane,
I'm not sure if it is possible (could not find anything on the web) but I would like to create an appointment in outlook and automatically 2 additional appointments will be created: one appointment 7 days before the initial appointment and one appointment 1 day after the initial appointment.
Do you know if this is possible?
Many thanks in advance!
Kind regards,
Johan.
Diane Poremsky says
It is possible with a macro. I'd use the code code above but remove the input lines. Set the starts for #2 and 3 to = objAppt.start+7 or objappt.start+1
Johan says
Hi Diane,
thanks for your reply. Unfortunately I'm really bad with macro's so I don't really know what you mean. Is it maybe possible to show me the exact code?
Thanks a lot already for all your input so far!
Johan.
Diane Poremsky says
I can now - i was on a business trip and working on a netbook and have a hard time working on it. :) Do you want to create just the 3 appointments, 7 before, 'now', 1 after?
Replace the code from the first If to the last End If with this to create 2 companion appointments.
If TypeName(objAppt) = "AppointmentItem" Then
Set objAppt2 = Application.CreateItem(olAppointmentItem)
With objAppt
' I'm using a limited number of fields, you can
' add others.
objAppt2.Subject = .Subject
objAppt2.Location = .Location
objAppt2.Body = .Body
objAppt2.Start = .Start - 7
objAppt2.Duration = .Duration
objAppt2.Categories = .Categories
End With
On Error Resume Next
objAppt2.Save
' create the second appointment
Set objAppt3 = Application.CreateItem(olAppointmentItem)
With objAppt
objAppt3.Subject = .Subject
objAppt3.Location = .Location
objAppt3.Body = .Body
objAppt3.Start = .Start - 7
objAppt3.Duration = .Duration
objAppt3.Categories = .Categories
End With
On Error Resume Next
objAppt3.Save
End If
ECM says
Hi Diane...I need to create an appointment (Outlook 2007) that recurs every 1, 3, 6, 9, 11 and 12 months from a given date. Is this possible either via code or a third-party add-on? Sorry if this does not provide you with enough info...let me know if you need more. Many thanks in advance...
Diane Poremsky says
You'll need to make individual appointments - there was an add-in but AFAIK, its not longer available so code is the only way to automate it. You could also use Excel and import. Because most fit a pattern you could create do it with 2 appointments
This will do two appt - create the first appt then run the macro. one recurs and covers 1,3,6,9 , 12 and one for 11. It needs tweaked a little - but that is a good start.
CreateTwoPatterns
Raymond says
Thank you Very Much! Your code worked flawlessly. I got my project completed and I have learned alot along the way. I wish there was a better way to thank you, like mail a gift card or something. Email me an address where I can send a Thank you card. I also don't mind sharing my final code in case someone else would like to refer to it, but I am not sure if I totally followed the convention.
Thank you Diane for taking your time to share your knowledge with others( including me). Be blessed!
Diane Poremsky says
My coding doesn't always follow conventions either.
Raymond says
Hello Diane,
Thank you very much for all the help. I was able to get the Holiday function to check all the recurring instances of 1st appointment, but I cant get it to check any instance of second Appointment. How would I tweak it to check other appointments? Thank you!
Diane Poremsky says
The second one picks up the date here:
objAppt3.Start = objAppt2.Start + Offset
instead, you'll need to do something like this after the first appt is saved:
newdate = objAppt2.Start + Offset
nextdate = holidayfunction(Format(newdate, "MM/dd/yyyy"))
' create the second appointment
Set objAppt3 = Application.CreateItem(olAppointmentItem)
With objAppt
'.............
objAppt3.Start = nextdate
**corrected- make sure you use the holiday function and not the 1st Monday function. :)
Diane Poremsky says
This is what i used to run the date through the holiday functiom:
newdate = objAppt2.Start + Offset
newdate = NextWeekDaySeries(Format(newdate, "MM/dd/yyyy"))
and then used this in the appt:
objAppt3.Start = Format(newdate, "MM/dd/yyyy") & _
" " & Format(objAppt.Start, "hh:mm AMPM")
Raymond says
I will leave code as is because its working fine. I am still working on the holiday function, and I will share it here once I get it working.. Everything else worked flawlessly after following your instructions. You have been of great help, Diane. Thank you!
Raymond says
I seem to be making progress. That code did actually work, and set the two appointments like I wanted it to. I haven't tested it against my custom holidays. I still have to tweak it a little bit more. One more question is there a way to change this line { Set objAppt = GetCurrentItem() } so that I can run the macro without opening an event window? . Would you mind suggesting a good book that has programming for outlook. Thank you very much for all the help and have a wonderful day.
Diane Poremsky says
That line allows it to work with selected or open appointments. If you mean you want to avoid using an existing or new appointment to supply the details, you'd need to create a userform to collect the subject, start, end time etc.
Raymond says
Thank you so much Diane. I will give it a try over the weekend. By the way do you have any books you have written? I would like to purchase one. I learn more from your links than most books I find out there. You are so helpful.
Diane Poremsky says
My last book was for outlook 2003 - I'm working on a 2013 version but it won't have any programming in it.
Raymond says
Hello Diane Poremsky,
I like what you have done with the code. I am not the greatest programmer but I need to get something done. I want to be able to set several recurring events The first event A will be every second Wednesday of every month. The event B will be 27 days prior to event A (B is dependent on A). However, if any of the events fall on a holiday, then its pushed back one day. Thank you!
Diane Poremsky says
A would use this line:
' calculate other dates in this line, "pdtmdate +14,"
pdtmdate = Format(pdtmdate +7, "MM/dd/yyyy")
I don't have a holiday function handy, but you'd test pdtmdate against a list of dates and if they match, adjust the date
if pdtmdate = TestHoldiay(pdtmdate) then
pdtmdate = pdtmdate +1
end if
B uses this in the macro
objAppt3.Start = pdtmdate - 27
But to test it against the holiday list, you'll need to get the date and test it against the holiday array then pass it on to the start field
sndDate = pdtmdate - 27
if sndDate = TestHoldiay(sndDate) then
sndDate = sndDate +1
end if
To get the first Wed, you'd adjust the offsets in the FirstMondayofMonth function: (change all FirstMondayofMonth to FirstWedofMonth might be less confusing too.)
Function FirstMondayofMonth(pdtmdate As Date) As Date
Dim dtmFirstOfMonth As Date
dtmFirstOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate), 1)
Select Case Weekday(dtmFirstOfMonth)
Case vbMonday: FirstMondayofMonth = dtmFirstOfMonth + 2
Case vbTuesday: FirstMondayofMonth = dtmFirstOfMonth + 1
Case vbWednesday: FirstMondayofMonth = dtmFirstOfMonth
Case vbThursday: FirstMondayofMonth = dtmFirstOfMonth + 6
Case vbFriday: FirstMondayofMonth = dtmFirstOfMonth + 5
Case vbSaturday: FirstMondayofMonth = dtmFirstOfMonth + 4
Case vbSunday: FirstMondayofMonth = dtmFirstOfMonth + 3
End Select
End Function
I'll see if i can find a holiday function. I have one for weekdays and holidays i can probably tweak to do only holidays.
Diane Poremsky says
See if this works correctly - https://www.slipstick.com/s/patterns2.txt - it seems to here.
Michael says
This looks very interesting, and it solves some of my scheduled events problems.
My remaining problem is that for many events, I need to count work days only, counting backwards from the last business day of the month, quarter, or year, where business days are Monday through Friday.
Event #1 occurs three work days before the last business day of the month.
Event #2 is two work days before the last business day of the month.
Event #3 is the last business day of the month.
I assume any code that could do this could also be adapted to count backwards from quarter end and year end.
I assume that holidays will be adjusted for manually.
I'm relatively new to Outlook, but I'm very surprised that this isn't available by default in Outlook. It seems to me that month end, quarter end, and year end deadlines would be common enough to make this a priority.
Diane Poremsky says
Yeah, the recurring patterns leave much to be desired.
This *should* work for the 3rd business day before the EOM - it works for the months I tested it, I'm not sure if i hit every last day of month though.
Function LastMondayofMonth(pdtmdate As Date) As Date
Dim dtmLastOfMonth As Date
dtmLastOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate) + 1, 0)
Select Case Weekday(dtmLastOfMonth)
Case vbMonday: LastMondayofMonth = dtmLastOfMonth - 4
Case vbTuesday: LastMondayofMonth = dtmLastOfMonth - 4
Case vbWednesday: LastMondayofMonth = dtmLastOfMonth - 2
Case vbThursday: LastMondayofMonth = dtmLastOfMonth - 2
Case vbFriday: LastMondayofMonth = dtmLastOfMonth - 2
Case vbSaturday: LastMondayofMonth = dtmLastOfMonth - 3
Case vbSunday: LastMondayofMonth = dtmLastOfMonth - 4
End Select
End Function
The full code I used, creating just one appt per month - to create one for each of the last 3 days, duplicate the block that creates the second appt and use +1 and +2 in the date field.
3rd workday from EOM
John says
I am just like Stephen and not a programmer. I would like to set up appointmets for days after a certain day in the month. I would like to set calander reminders for the tuesdays after the Second and Third mondays of each month. Is there any way that you can help me wit this?
Diane Poremsky says
Use the code sample and replace the function with the following. Create an appointment with the subject and times filled in for the first date in the series - the macro picks up this to use in the appointments it creates.. (Or select any date in the prior month)
Function FirstMondayofMonth(pdtmdate As Date) As Date
Dim dtmFirstOfMonth As Date
dtmFirstOfMonth = DateSerial(Year(pdtmdate), Month(pdtmdate), 1)
Select Case Weekday(dtmFirstOfMonth)
Case vbMonday: FirstMondayofMonth = dtmFirstOfMonth + 8
Case vbTuesday: FirstMondayofMonth = dtmFirstOfMonth + 14
Case vbWednesday: FirstMondayofMonth = dtmFirstOfMonth + 13
Case vbThursday: FirstMondayofMonth = dtmFirstOfMonth + 12
Case vbFriday: FirstMondayofMonth = dtmFirstOfMonth + 11
Case vbSaturday: FirstMondayofMonth = dtmFirstOfMonth + 10
Case vbSunday: FirstMondayofMonth = dtmFirstOfMonth + 9
End Select
End Function
Teddy S says
Nice piece of code Diane! Is there a way to keep the individual occurences as series though?
Diane Poremsky says
No. If you want to keep the series, you need to change the end date (or set one when you created the appt.)
Fred R (@rntt1) says
My challenge is having a daily recurring appointment (same time each week) but the time changes each week according to the time of sunset. I have a couple of Orthodox Jews on my staff who have to go for prayers, so I need to arrange coverage for them. The prayer times are based on sunset, so varies each week. For example, this week they have to leave at 4 and be gone for an hour. Next week, 3:45. The week after, 3:30 until Dec 21 when it starts reversing. Any ideas?
Diane Poremsky says
I think I would get a file with the sunset times and work up a chart in Excel then import it. There are internet calendar subscriptions that have sunset times that you could use too - they wouldn't have the times you'd need to leave/pick them up, only the sunset time.
Stephen Elms says
Hi Diana, I regret that as a non-programmer that I do not have the time to apply your code to the number of appointments I need to create. Most of these are x day(sd) before the x(recurring) day of the month in a certain period each year. So far I have found no one has been able to this.
Diane Poremsky says
If you can give me an example of the dates you need, I'll take a look.
The code as written creates 2 appointments per month, one on the first Monday of the month and the second one x days later. The "first Monday" can be changed to second Wednesday, 4th Friday etc. It doesn't account for weekdays only either, although it could be incorporated into this, but this is more of a 'see what you can do' code sample and I didn't want to make it too confusing.