Macro fails to create appointments based on worksheet data

I have an Excel macro that I run, which takes activity names, dates and times from the spreadsheet and places them into the Outlook calendar. This works fine when Outlook is running, but when it is not, the macro does not make the appointments.

I have made an error checking piece that checks to see if a running instance of Outlook is running and if not creates one but it still only works when Outlook is running.

Any ideas why??

Sub SetAppt()
  ' Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim olApp As Object

    'if an instance of outlook is not open then create an instance of the application
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")

    If er.Number = 429 Then
      Set olApp = CreateObject("Outlook.Application.14")
    End If

    On Error GoTo 0

    Set olApp = CreateObject("Outlook.Application")
    ' Set olApp = New Outlook.Application

    'declare an index for all the variables
     Dim i As Integer
     i = 2

    'declare the variables that will hold the data and set their initial value
     Dim occ, actName, srtTime, duration As String
     occ = "A" & i
     actName = "B" & i
     srtTime = "F" & i
     duration = "G" & i

     'for holding different parts of the dates/times that will be split
     Dim splitStr() As String
     Dim splitDrtion() As String

     'loop until there is no more items
     While Range(occ).Value <> ""

      'create a new appointment
      Set olApt = olApp.CreateItem(olAppointmentItem)

      'we must split the start time and date
      splitStr = Split(Range(srtTime).Value, " ")

      Dim oDate As Date
      oDate = splitStr(0)

      'we must also spilt the duration (number/hour)
      splitDrtion = Split(Range(duration).Value, " ")

        'with is used to acces the appointment items properties
        With olApt

          .Start = oDate + TimeValue(splitStr(1))

          'if the duration is in hours then multiply number else leave it
          If splitDrtion(1) = "Hour" Then
            .duration = 60 * splitDrtion(0)
            .duration = splitDrtion(0)
          End If

          .Subject = Range(occ).Value
          .Body = Range(actName).Value
         End With

        'increment i and reset all the variables with the new number
        i = i + 1
        occ = "A" & i
        actName = "B" & i
        srtTime = "F" & i
        duration = "G" & i

        Set olApt = Nothing
      Set olApp = Nothing
End Sub


  • Building on Siddharth's example, here is a refactored version of your code.

    Sub SetAppt()
      Dim olApt As Object ' Outlook.AppointmentItem
      Dim olApp As Object ' Outlook.Application
      Dim i As Long
      Dim apptRange As Variant
      Const olAppointmentItem As Long = 1
      ' create outlook
      Set olApp = GetOutlookApp
      If olApp Is Nothing Then
        MsgBox "Could not start Outlook"
        Exit Sub
      End If
      ' read appts into array
      apptRange = Range(Cells(2, 1), Cells(Rows.Count, 7).End(xlUp)).value
      For i = LBound(apptRange) To UBound(apptRange)
        Set olApt = olApp.CreateItem(olAppointmentItem)
        With olApt
          .Start = apptRange(i, 6)
          If InStr(apptRange(i, 7), "Hour") > 0 Then
            ' numeric portion cell is delimited by space
            .Duration = 60 * Split(apptRange(i, 7), " ")(0)
            .Duration = apptRange(i, 7)
          End If
          .Subject = apptRange(i, 1)
          .Body = apptRange(i, 2)
        End With
      Next i
    End Sub
    Function GetOutlookApp() As Object
      On Error Resume Next
      Set GetOutlookApp = CreateObject("Outlook.Application")
    End Function

    This code reads your worksheet data into an array. This avoids the time penalty that comes from the COM interaction between VBA and Excel.

    We loop through the array and create a new appointment for each row.

    Using the following sample data, it worked regardless of whether Outlook was open or not (Outlook being closed makes it obviously slower, however).

    sample appts

    There is in fact no need to check if Outlook is open.