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?
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!
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