Public Sub CreateAppointmentSeries()
  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
  Dim dDate, pdtmdate 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)")

'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 + 7, "MM/dd/yyyy")
      
pdtmdate = TestHoliday(pdtmdate)


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 = 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
       
       

dDate = TestHoliday(pdtmdate - 27)

' create the second appointment
 Set objAppt3 = Application.CreateItem(olAppointmentItem)
      With objAppt
        objAppt3.Subject = "27 " & .Subject & x
        objAppt3.Location = .Location
        objAppt3.Body = .Body
        objAppt3.Start = dDate
        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 + 2
         Case vbTuesday: FirstMondayofMonth = dtmFirstOfMonth + 1
         Case vbWednesday: FirstMondayofMonth = dtmFirstOfMonth
         Case vbThursday: FirstMondayofMonth = dtmFirstOfMonth + 6
         Case vbFriday: FirstMondayofMonth = dtmFirstOfMonth + 5
         Case vbSaturday: FirstMondayofMonth = dtmFirstOfMonth + 4
         Case vbSunday: FirstMondayofMonth = dtmFirstOfMonth + 3
         
    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

Function TestHoliday(pdate As Date) As Date
  Dim nDate As Date

 nDate = pdate

 
 ' 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("5/8/2013", "5/16/2013", "5/27/2013", "7/10/2013", "7/18/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(nDate, arrHolidays(i)) Then nDate = DateAdd("d", 1, nDate)
   
  Select Case Weekday(nDate, vbUseSystemDayOfWeek)
  Case vbSunday
    nDate = DateAdd("d", 1, nDate)
  Case vbSaturday
    nDate = DateAdd("d", 2, nDate)
  End Select
 
Next i
 
  TestHoliday = CDate(nDate)
  
End Function