Create Outlook appointments using multiple recurring patterns

Last reviewed on May 28, 2013

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
' 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
     ' Get the next month before looping back through   
If Format(pdtmdate, "mm") < 12 Then
    pdtmdate = Format(pdtmdate, "mm") + 1 & "/" & Format(pdtmdate, "yyyy")
   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

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

Please post long or more complicated questions at Outlookforums.

34 responses to “Create Outlook appointments using multiple recurring patterns”

  1. Stephen Elms

    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.

  2. Fred R (@rntt1)

    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?

  3. Teddy S

    Nice piece of code Diane! Is there a way to keep the individual occurences as series though?

  4. John

    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?

  5. Michael

    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.

  6. Raymond

    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!

  7. Raymond

    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.

  8. Raymond

    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.

  9. Raymond

    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!

  10. Raymond

    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!

  11. Raymond

    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!

  12. ECM

    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...

  13. Johan

    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,

  14. kris

    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

  15. Joe Campagna

    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?

  16. Joe Campagna

    Thanks for the reply Diane, I'll go the "3rd" route. Response appreciated...

Leave a Reply

If the Post Coment button disappears, press your Tab key.