Create Outlook appointments using multiple recurring patterns

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