Create Outlook appointments using multiple recurring patterns

Last reviewed on May 28, 2013   —  42 comments

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

About Diane Poremsky

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 Outlook forums by Slipstick.com.

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

    1. Diane Poremsky

      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.

  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?

    1. Diane Poremsky

      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.

  3. Teddy S

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

    1. Diane Poremsky

      No. If you want to keep the series, you need to change the end date (or set one when you created the appt.)

  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?

    1. Diane Poremsky

      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

  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.

    1. Diane Poremsky

      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

  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!

    1. Diane Poremsky

      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.

    2. Diane Poremsky

      See if this works correctly - http://www.slipstick.com/s/patterns2.txt - it seems to here.

  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.

    1. Diane Poremsky

      My last book was for outlook 2003 - I'm working on a 2013 version but it won't have any programming in it.

  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.

    1. Diane Poremsky

      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.

  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!

    1. Diane Poremsky

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

    2. Diane Poremsky

      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")

  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!

    1. Diane Poremsky

      My coding doesn't always follow conventions either.

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

    1. Diane Poremsky

      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

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

    1. Diane Poremsky

      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

    2. Johan

      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.

    3. Diane Poremsky

      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

  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
    Kris

    1. Diane Poremsky

      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.

  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?

    1. Diane Poremsky

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

  16. Joe Campagna

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

  17. Fiona

    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!

    1. Diane Poremsky

      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.

  18. bhim

    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.

    1. Diane Poremsky

      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.

  19. bhim

    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

  20. Adrie Rijnen

    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

  21. Chris

    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.

Leave a Reply

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

This site uses XenWord.