One big complaint about Outlook recurrence patterns is that there is not a pattern for Every xx weekday (Monday - Friday). You can create appointments for specific days of the week, but the every xx days pattern includes Saturday and Sunday.
The solution: a macro that copies the appointment details to a new appointment, using a function to check the day of the week for each date. When a date falls on Saturday or Sunday, it jumps ahead to Monday.
Updated March 31 2017. Now using Chip Pearson's Workday2 function to skip Workdays, so it is now a proper "every xx weekday" macro. (Yes, it's an Excel macro but since the Office programs use pretty much the same functions, it works in Outlook too.) It will also check your default calendar for all day events marked busy to use in the Holiday array. It does not check recurring events!
To use, you need to create the first appointment and save it, then run the macro. Enter the number of days between appointments and the number of appointments you need to create. The macro copies the fields from the first appointment and creates new appointments every xx days. Note: these are not recurring appointments, but individual appointments.
It will work with either opened appointments or selected appointments thanks to the GetCurrentItem function.
Create Every xx Weekday Series
To use, press Alt+F11 to open the VB Editor. Expand the folders on the left and right click to Insert a new module. Paste the following code into a module. Create a new appointment and save it, then run the macro.
As written, the macro skips Saturday and Sunday (65). If your workweek has other days off, add the values listed in Enum EDaysOfWeek and change the value in nextDate = Workday2(currentDate, NumOfDays + 1, 65) and in nextDate = Workday2(nextDate, NumOfDays + 1, 65).
Dim strAllDayOOF As String '''''''''''''''''''''''''''''''''''''''''''''''''''' ' From http://www.cpearson.com/excel/BetterWorkday.aspx ' EDaysOfWeek ' Days of the week to exclude. This is a bit-field ' enum, so that its values can be added or OR'd ' together to specify more than one day. E.g,. ' to exclude Tuesday and Saturday, use ' (Tuesday+Saturday), or (Tuesday OR Saturday) ''''''''''''''''''''''''''''''''''''''''''''''''''''' Enum EDaysOfWeek Sunday = 1 ' 2 ^ (vbSunday - 1) Monday = 2 ' 2 ^ (vbMonday - 1) Tuesday = 4 ' 2 ^ (vbTuesday - 1) Wednesday = 8 ' 2 ^ (vbWednesday - 1) Thursday = 16 ' 2 ^ (vbThursday - 1) Friday = 32 ' 2 ^ (vbFriday - 1) Saturday = 64 ' 2 ^ (vbSaturday - 1) End Enum Public Sub CreateSeriesofAppt() Dim objAppt As Outlook.AppointmentItem Dim objAppt2 As Outlook.AppointmentItem Dim NumOfDays As Long Dim NumAppt As Long Dim nextDate As Date Dim nextAppt Dim currentDate As Date ' Get the Holdiay list GetHolidays ' Don't forget the GetCurrentItem function at ' http://slipstick.me/e8mio Set objAppt = GetCurrentItem() If TypeName(objAppt) <> "AppointmentItem" Then MsgBox "You need to select and appointmnet" Else NumOfDays = InputBox("How many days between appointments?") NumAppt = InputBox("How many appointments in the series?") currentDate = Format(objAppt.Start, "mm/dd/yyyy") ApptStartTime = Format(objAppt.Start, "hh:mm:ss AM/PM") ' Using Function from ' From http://www.cpearson.com/excel/BetterWorkday.aspx ' 65 = skip Sat/Sun nextDate = Workday2(currentDate, NumOfDays + 1, 65) For x = 1 To NumAppt Set objAppt2 = Session.GetDefaultFolder(olFolderCalendar).Items.Add(olAppointmentItem) apptStartDateTime = nextDate & " " & ApptStartTime With objAppt ' I'm using a limited number of fields, you can ' add others. objAppt2.Subject = .Subject & " " & x objAppt2.Location = .Location objAppt2.Body = .Body objAppt2.Start = apptStartDateTime objAppt2.Duration = .Duration objAppt2.Categories = .Categories End With On Error Resume Next objAppt2.Save 'objAppt2.Display nextDate = Workday2(nextDate, NumOfDays + 1, 65) Debug.Print nextAppt Next x End If Set objAppt = Nothing Set objAppt2 = Nothing End Sub ' From http://www.cpearson.com/excel/BetterWorkday.aspx ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Workday2 ' This is a replacement for the ATP WORKDAY function. It ' expands on WORKDAY by allowing you to specify any number ' of days of the week to exclude. ' StartDate The date on which the period starts. ' DaysRequired The number of workdays to include ' in the period. ' ExcludeDOW The sum of the values in EDaysOfWeek ' to exclude. E..g, to exclude Tuesday ' and Saturday, pass Tuesday+Saturday in ' this parameter. ' Holidays an array or range of dates to exclude ' from the period. ' RESULT: A date that is DaysRequired past ' StartDate, excluding holidays and ' excluded days of the week. ' Because it is possible that combinations of holidays and ' excluded days of the week could make an end date impossible ' to determine (e.g., exclude all days of the week), the latest ' date that will be calculated is StartDate + (10 * DaysRequired). ' This limit is controlled by the RunawayLoopControl variable. ' If DaysRequired is less than zero, the result is #VALUE. If ' the RunawayLoopControl value is exceeded, the result is #VALUE. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' From http://www.cpearson.com/excel/BetterWorkday.aspx Function Workday2(StartDate As Date, DaysRequired As Long, _ ExcludeDOW As EDaysOfWeek, Optional Holidays As Variant) As Variant Dim N As Long ' generic counter Dim C As Long ' days actually worked Dim TestDate As Date ' incrementing date Dim HNdx As Long ' holidays index Dim CurDOW As EDaysOfWeek ' day of week of TestDate Dim IsHoliday As Boolean ' is TestDate a holiday? Dim RunawayLoopControl As Long ' prevent infinite looping Dim V As Variant ' For Each loop variable for Holidays. Holidays = Split(strAllDayOOF, ",") If DaysRequired < 0 Then ' day required must be greater than or equal ' to zero. Workday2 = CVErr(xlErrValue) Exit Function ElseIf DaysRequired = 0 Then Workday2 = StartDate Exit Function End If If ExcludeDOW >= (Sunday + Monday + Tuesday + Wednesday + _ Thursday + Friday + Saturday) Then ' all days of week excluded. get out with error. Workday2 = CVErr(xlErrValue) Exit Function End If ' this prevents an infinite loop which is possible ' under certain circumstances. RunawayLoopControl = DaysRequired * 10000 N = 0 C = 0 ' loop until the number of actual days worked (C) ' is equal to the specified DaysRequired. Do Until C = DaysRequired N = N + 1 TestDate = StartDate + N CurDOW = 2 ^ (Weekday(TestDate) - 1) If (CurDOW And ExcludeDOW) = 0 Then ' not excluded day of week. continue. IsHoliday = False ' test for holidays If IsMissing(Holidays) = False Then For Each V In Holidays If V = TestDate Then IsHoliday = True ' TestDate is a holiday. get out and ' don't count it. Exit For End If Next V End If If IsHoliday = False Then ' TestDate is not a holiday. Include the date. C = C + 1 End If End If If N > RunawayLoopControl Then ' out of control loop. get out with #VALUE Workday2 = CVErr(xlErrValue) Exit Function End If Loop ' return the result Workday2 = StartDate + N End Function Sub GetHolidays() ' Check for all day events on calendar ' marked busy/off/tentative ' skips recurring events ' To be included, holidays need to be marked with a busy state, not Free Dim CalItems As Outlook.Items Dim ResItems As Outlook.Items Dim sFilter As String Dim iNumRestricted As Integer Dim itm As Object ' Use the selected calendar folder Set CalFolder = Session.GetDefaultFolder(olFolderCalendar) Set CalItems = CalFolder.Items ' Sort all of the appointments based on the start time CalItems.Sort "[Start]" CalItems.IncludeRecurrences = False ' Set dates sFilter = "[Start] >= '" & Date & "' And [AllDayEvent] = 'True' And [BusyStatus] <> '0' AND [IsRecurring] = 'False'" Set ResItems = CalItems.Restrict(sFilter) iNumRestricted = 0 'Loop through the items in the collection. For Each itm In ResItems iNumRestricted = iNumRestricted + 1 ' Create list of dates strAllDayOOF = strAllDayOOF & Format(itm.Start, "mm/dd/yyyy") & "," Next Debug.Print strAllDayOOF ' clean the string for the array strAllDayOOF = Left(strAllDayOOF, Len(strAllDayOOF) - 1) Set ResItems = Nothing Set CalItems = Nothing Set CalFolder = Nothing End Sub
I get the same error as this person at the same place.
I get "User type not defined" at
Function Workday2(StartDate As Date, DaysRequired As Long, _
ExcludeDOW As EDaysOfWeek, Optional Holidays As Variant) As Variant
I created an appointment the same day name Monthly_Data_Match and then ran the macro and it failed. I checked that I copied the entire code. I have a lot of references checked for outlook already. I can provide a copy of that list, but was not able to attach. Any help is appreciated.
I get "User type not defined" at
Function Workday2(StartDate As Date, DaysRequired As Long, _
ExcludeDOW As EDaysOfWeek, Optional Holidays As Variant) As Variant
Did you copy the entire macro on the page? That error usually means you don't have references set. Does it stop on any specific line?
Code fails at line'
Set objAppt = GetCurrentItem()
Compiler says sub or function not define.
oh, you need the GetCurrentItem function from https://www.slipstick.com/developer/outlook-vba-work-with-open-item-or-select-item/#getcurrentitem - will update the article to mention that.
Hello! Thank you for the macro. I am having trouble to make the appointment in every 20th day. I need to create appontment in every 20th day regardless of whether it is saturday, sunday or holiday.
I tried edit the macro but I didnt get it work. Can someone help?
how can create the same for multiple tasks and for a group
Nice! Thanks!
Just what I was looking for, allthough I had a slightly different repeat... but you inspired me!
Any chance we can see that done to also exclude a list of holidays?
Holidays are a bit harder to work around since you need a list of dates. It's not impossible, it's just not as easy.
You can add something like this to it (before or after the Select case block )
- but there are two problems. 1) if the nextdate is another date in the array, the macro doesn't go back and check it. If the holiday is Monday, the Sat & Sun routine doesn't skip it.When its after the Sat/Sun routine, it properly skips Monday holidays but if the recurrence pattern pushes it into the next weekend, that won't be checked.
It can get unwieldy with a lot of dates. You also need to update the dates on a regular basis. Better, but more complicated, would be to get the dates of all Holiday categories within the expected span - sounds like a fun project when i have some free time. If more holidays are static, you could check just the month and day.
Dim arrCat As Variant
arrCat = Array("11/1/2012", "11/3/2012", "11/5/2012", "11/7/2012", "11/9/2012", "12/1/2012", "12/3/2012", "12/5/2012", "12/7/2012", "12/11/2012", "12/18/2012", "12/24/2012", "12/25/2012")
' Go through the array and look for a match, then do something
For i = LBound(arrCat) To UBound(arrCat)
If InStr(nextDate, arrCat(i)) Then nextDate = DateAdd("d", 1, nextDate)
Next i
Actually, in thinking about this, I wasn't thinking it through completely.
The array code after the Sat/Sun check code should work - if a holiday is Fri, you can add sat & sun to the array as it loops to the next date in the array. (I forgot about the i, next i loop checking the next date in the array).
arrCat = Array("11/1/2012", "11/2/2012", "11/3/2012", "11/7/2012", "11/29/2012", "11/30/2012", "12/3/2012", "12/9/2012", "12/11/2012", "12/18/2012", "12/24/2012", "12/25/2012", "12/26/2012", "12/31/2012", "1/1/2013")