Macro fails to create appointments based on worksheet data - excel

Question

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)
Else
.duration = splitDrtion(0)
End If
.Subject = Range(occ).Value
.Body = Range(actName).Value
.Save
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
Wend
Set olApp = Nothing
End Sub

Answer 1

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)
Else
.Duration = apptRange(i, 7)
End If
.Subject = apptRange(i, 1)
.Body = apptRange(i, 2)
.Save
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).
There is in fact no need to check if Outlook is open.

Answer 2

Instead of
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")
Try this
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Err.Clear
On Error GoTo 0
Since I cannot test it, here is your code with the necessary updates. Please try this.
Sub SetAppt()
Dim olApt As Object, olApp As Object
Dim i As Integer
Dim occ As String, actName As String, srtTime As String, duration As String
Dim splitStr() As String, splitDrtion() As String
Dim oDate As Date
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Err.Clear
On Error GoTo 0
'declare an index for all the variables
i = 2
'declare the variables that will hold the data and set their initial value
occ = "A" & i
actName = "B" & i
srtTime = "F" & i
duration = "G" & i
'loop until there is no more items
While Range(occ).Value <> ""
'create a new appointment
Set olApt = olApp.CreateItem(1)
'we must split the start time and date
splitStr = Split(Range(srtTime).Value, " ")
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)
Else
.duration = splitDrtion(0)
End If
.Subject = Range(occ).Value
.Body = Range(actName).Value
.Save
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
Wend
Set olApp = Nothing
End Sub