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
I would be forever in your debt if you can figure out how to make this pattern happen. I got close but not on the Grey and Black and not without having 3 different VBAs, one for each set.
Yellow - 2nd Tuesday of the month
Blue - 1st Friday after Yellow
Orange - 3rd Tuesday of the month
Red - 1st Wed after Orange
Grey - 1st Tuesday of the month
Black - 1st Friday before Grey
If any of the dates (except Yellow) falls on a Holiday, pick the day before if it is a weekday else the first day after holiday if it is a weekday.
Or, create appointments in new Google calendar, export to ics file and import into Outlook
to make a weird recurring pattern?
Would it be possible to create a recurring calendar event that excludes ever other Wednesday, after the creation of the event?
to make a truly recurring event, you'd need to set exceptions. The macro on this page creates individual events - it could create the pattern you want if you calculate the pattern correctly.
Hello. Thanks for the code.
Is there a way to get the appts to use the reoccurrence feature so they can be edited at one time?
For example, if I use your script to creatre my appts they look to be separate. So if I want to update my invitee list, or the subject I will have to do it for each individual appt. Any way to do this through one edite rather than multiple edits?
Thank you.
you can use a script to create recurring appointments that are in one of outlook's patterns, it could do the exceptions too, but too many exceptions tend to corrupt it. Individual events (what this script does) are definitely better for appointments but more annoying for meetings. I don't think i have any example code that creates recurring with exceptions, but will check.
Sweet! Macro totally works. Thanks so much, Diane!
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
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.
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.
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.
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