Adding vacation days to Outlook in bulk from Excel

A friend sent me a spreadsheet with a list of dates. He wants to put them on his calendar as vacation days, but doesn't want to do it manually. Hooray, another free job.

The list of dates starts in cell A2, with A1 being a header row. Nice! I love those kinds of worksheets.

All we need now is a little procedure to loop through the range and add an appointment to the Outlook calendar, making it a vacation day. Here's what I came up with.

Sub CreateAppointments(Optional subject As String = "Vacation", _
    Optional columnLetter As String = "A")

Dim cell As Excel.Range
Dim rng As Excel.Range
Dim wholeColumn As Excel.Range
Dim startingCell As Excel.Range
Dim oApp As Object  ' Outlook.Application
Dim appt As Object  ' Outlook.AppointmentItem
Dim wkbk As Excel.Workbook
Dim wksht As Excel.Worksheet
Dim lastRow As Long
Dim arrData As Variant
Dim i As Long

  ' late bound constants
Const olAppointmentItem As Long = 1
Const olOutOfOffice As Long = 3

  ' get range of dates
  Set wkbk = ActiveWorkbook
  Set wksht = wkbk.ActiveSheet
  Set wholeColumn = wksht.Range(columnLetter & ":" & columnLetter)
  lastRow = wholeColumn.End(xlDown).Row - 2
  Set startingCell = wksht.Range(columnLetter & "2")
  Set rng = wksht.Range(startingCell, startingCell.Offset(lastRow))

  ' start Outlook
  Set oApp = GetOutlookApp

  If oApp Is Nothing Then
    MsgBox "Could not start Outlook.", vbInformation
    Exit Sub
  End If

  ' read range into array in one go
  arrData = Application.Transpose(rng.Value)

  ' loop through array, not range
  For i = LBound(arrData) To UBound(arrData)

    ' create new appt and set appropriate properties
    Set appt = oApp.CreateItem(olAppointmentItem)

    With appt
      .AllDayEvent = True  ' block out the whole day
      .body = subject
      .Start = arrData(i)  ' no need to set End Property for all-day events
      .subject = subject
      .BusyStatus = olOutOfOffice
      .ReminderSet = False  ' no need for reminder, right?
      .Save
    End With
  Next i

End Sub

Function GetOutlookApp() As Object
' return Outlook.Application object
  On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

The procedure lets you decide what you want to call each appointment. I assume "Vacation", but if you were using this procedure to block out a series of dates for a professional development conference, you would call it something else.

You can also specify the column, if the data is somewhere other than column A. For example, if your dates were in column H starting in cell H2, with H1 as the header cell, you would call the function like this:

Call CreateAppointments(, "H")

The first thing the procedure does is determine the range being used to hold the dates. After starting Outlook, the range is read into a Variant (array) and then looped. For a simple task like this we could have also used a 'For Each cell in Range'-type loop, but I chose to actually follow best practices and use an array instead of touching the worksheet repeatedly.

For each appointment, we set three key properties: AllDayEvent, Start and BusyStatus. These are the ones that will make each one a vacation day.

Sample Usage

Sub TestCreateAppt()

  Call CreateAppointments("On my way to Excel DevCon 2010")

End Sub

Download sample workbook

Related Articles:

• April 5, 2010 -- Convert multi-day appointments into multiple all-day ones
• January 27, 2010 -- Automatically attach a file to all outgoing messages
• December 28, 2009 -- Create Distribution Lists from Email