Last reviewed on May 28, 2013   —  44 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

Comments

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Leave a Reply

Please post long or more complicated questions at OutlookForums by Slipstick.com.

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