Create Outlook appointments for every xx weekday

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.

Note: currently this is not a true "every xx weekday" it's every xx days and when the date falls on a weekend or holiday, move it to the next weekday. For example, every other day is every Monday, Wednesday, and Friday using this code, not Monday, Wednesday, Friday, Tues, Thursday...

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.

This macro does not skip holidays, only weekend dates. It will work with either opened appointments or selected appointments.

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.

Public Sub CreateSeriesofAppt()      
  Dim objAppt As Outlook.AppointmentItem
  Dim objAppt2 As Outlook.AppointmentItem
  Dim NumOfDays As Long
  Dim NumAppt As Long
  Dim nextAppt 'As Date
  
 Set objAppt = GetCurrentItem()
 If TypeName(objAppt) = "AppointmentItem" Then


NumOfDays = InputBox("How many days between appointments?")

NumAppt = InputBox("How many appointments in the series?")


nextAppt = NextWeekDaySeries(Format(objAppt.Start, "MM/dd/yyyy hh:mm"), NumOfDays + 1)
MsgBox nextAppt

For x = 1 To NumAppt
Set objAppt2 = Session.GetDefaultFolder(olFolderCalendar).Items.Add(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 = nextAppt
        objAppt2.Duration = .Duration

      End With
      

      On Error Resume Next

      objAppt2.Save
      objAppt2.Display
      
nextAppt = NextWeekDaySeries(Format(nextAppt, "MM/dd/yyyy hh:mm"), NumOfDays + 1)
MsgBox nextAppt
Next x

End If
  
    Set objAppt = Nothing
    Set objAppt2 = Nothing
    


End Sub



Function NextWeekDaySeries(dateFrom As Date, _
    Optional daysAhead As Long = 1) As Date
  Dim currentDate As Date
  Dim nextDate As Date
 
  ' convert neg to pos
  If daysAhead < 0 Then
    daysAhead = Abs(daysAhead)
  End If
 
  ' determine next date
  currentDate = dateFrom
  nextDate = DateAdd("d", daysAhead, currentDate)
 

 ' Check for holidays entered as mm/dd/yyyy format

Dim arrHolidays  As Variant

' US Federal holidays + day after Thanksgiving & Christmas eve/day after. 
arrHolidays = Array("11/11/2012", "11/22/2012", "11/23/2012", "12/24/2012", "12/25/2012", "12/26/2012", "12/31/2012", _
"1/1/2013", "1/21/2013", "2/18/2013", "5/27/2013", "7/4/2013", "9/2/2013", "11/11/2013", "11/28/2013", "11/29/2013", "12/24/2013", "12/25/2013", "12/26/2013", "12/31/2013", _
"1/1/2014", "1/20/2014", "2/17/2014", "5/26/2014", "7/4/2014", "9/1/2014", "11/11/2014", "11/27/2014", "11/28/2014", "12/24/2014", "12/25/2014", "12/26/2014", "12/31/2014", _
"1/1/2015", "1/19/2015", "2/16/2015", "5/25/2015", "7/4/2015", "9/7/2015", "11/11/2015", "11/26/2015", "11/27/2015", "12/24/2015", "12/25/2015", "12/26/2015", "12/31/2015", "1/1/2016")

' Go through the array and look for a match, then do something
For i = LBound(arrHolidays) To UBound(arrHolidays)
If InStr(nextDate, arrHolidays(i)) Then nextDate = DateAdd("d", 1, nextDate)
  
  Select Case Weekday(nextDate, vbUseSystemDayOfWeek)
  Case vbSunday
    nextDate = DateAdd("d", 1, nextDate)
  Case vbSaturday
    nextDate = DateAdd("d", 2, nextDate)
  End Select

Next i

  NextWeekDaySeries = CDate(nextDate)
 
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