Setting Outlook calendar dates with excel

C

conradcliff

Board Regular
Joined
Feb 24, 2010
Messages
58
Hey guys, so while I'm waiting for help on my other thread I thought I would try and get some info on this issue as well.

I want to create a calendar event with data located in different cells on the active sheet of a workbook. The cells holding the data will be the same every time I do this, just the data inside them will change.

I've found two different macro's for doing this but I'm not sure which one would be better suited for my needs. here's the first one:

Code: 
Sub ExportAppointmentsToOutlook()
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim blnCreated As Boolean
'Read the table with appointments:
    Dim arrAppt() As Variant, i As Long
    arrAppt = Range("A2", Cells(Rows.Count, "E").End(xlUp)).Value
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    On Error GoTo 0
'Create the outlook item for the table entries:
'Rows:
' Row 1 = date
' Row 2 = starttime
' Row 3 = endtime
' Row 4 = Description
' Row 5 = Location

    For i = LBound(arrAppt) To UBound(arrAppt)
    Set olApt = olApp.CreateItem(olAppointmentItem)

    With olApt
        .Start = arrAppt(i, 1) + arrAppt(i, 2)
        .End = arrAppt(i, 1) + arrAppt(i, 3)
        .Subject = arrAppt(i, 4)
        .Location = arrAppt(i, 5)
        .Body = "Created by excel tool"
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 5
        .ReminderSet = True
        .Save
    End With
    Next i

    Set olApt = Nothing
    Set olApp = Nothing
End Sub
The stuff that confuses me the most(that's not to say it all doesn't confuse me) about this bit of code is
Code: 
Dim arrAppt() As Variant, i As Long
    arrAppt = Range("A2", Cells(Rows.Count, "E").End(xlUp)).Value
and
Code: 
.Start = arrAppt(i, 1) + arrAppt(i, 2)
        .End = arrAppt(i, 1) + arrAppt(i, 3)
        .Subject = arrAppt(i, 4)
        .Location = arrAppt(i, 5)
Also, I need to have the body consist of values in specific cells on the active sheet as well.

I just don't know what this stuff means or how I'm supposed to change it to point to my information.

The other bit of code that I found is here:
Code: 
Sub ExportAppointmentsToOutlook()

    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    Dim blnCreated As Boolean
    Dim x As Variant, LastRow As Long, ws As Worksheet

'Read the table with appointments:
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        blnCreated = True
        Err.Clear
    Else
        blnCreated = False
    End If
    On Error GoTo 0

With ActiveSheet
        Set ws = ActiveWorkbook.Sheets(.Name)
    End With
    
    With ws.Range("A2:B" & ws.Rows.Count)
        LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
    
    For x = 2 To LastRow
    Set olApt = olApp.CreateItem(olAppointmentItem)

    With olApt
        .Start = Range("B" & x).Value
        .End = Range("C" & x).Value
        .Subject = Range("A" & x).Value
       .Location = Range("E" & x).value
        .BusyStatus = olBusy
        .ReminderSet = False
        .AllDayEvent = True
        .Save
    End With
    Next x


    Set olApt = Nothing
    Set olApp = Nothing

End Sub
This part makes me think it's searching for something:
Code: 
With ws.Range("A2:B" & ws.Rows.Count)
        LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart,  SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
which is why I don't think this one is as useful for my purposes as the other one. However, if you think it would be better I just need help figuring out how to input my cell ranges.

If anyone could give me some insight or point me in the right direction I would greatly appreciate it.. Thanks! :biggrin:
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Both routines create Outlook appointments row by row using the data in columns A:E, starting at row 2 and ending at the last row of data, but differ in the way they determine the last row.

Code: 
    Dim arrAppt() As Variant, i As Long
    arrAppt = Range("A2", Cells(Rows.Count, "E").End(xlUp)).Value
Cells(Rows.Count, "E").End(xlUp) looks in column E from the bottom upwards and returns the first populated cell. The result might be Range("A2", "E99"), and all the data in this range is put in arrAppt, a 2-dimensional array of n rows x 5 columns.
Code: 
For i = LBound(arrAppt) To UBound(arrAppt)
    Set olApt = olApp.CreateItem(olAppointmentItem)

    With olApt
        .Start = arrAppt(i, 1) + arrAppt(i, 2)
        .End = arrAppt(i, 1) + arrAppt(i, 3)
        .Subject = arrAppt(i, 4)
        .Location = arrAppt(i, 5)
The above snippet loops through this array row by row and takes each column (1-5), arrAppt(row,column) to create each appointment.

Note that the comment "'Rows:
' Row 1 = date" etc. is misleading: it should be columns!

The second routine:
Code: 
With ws.Range("A2:B" & ws.Rows.Count)
        LastRow = .Find(What:="*", after:=.Cells(1, 1), LookAt:=xlPart,  SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    End With
determines the last row by searching for "*" in the range A2:B65536 (Excel 2003) and then, instead of populating an array with this data, retrieves it directly from the cells to create each appointment.

A routine to create a single appointment from cells A1:E1 might be:
Code: 
Sub Create_Appointment()

    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0

    Set olApt = olApp.CreateItem(olAppointmentItem)
    
    With olApt
        .Start = Range("A1").Value
        .End = Range("B1").Value
        .Subject = Range("C1").Value
        .Location = Range("D1").Value
        .Body = Range("E1").Value
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 5
        .ReminderSet = True
        .Save
    End With

End Sub
 
Last edited:
Upvote 0
Wow, thank you so much for the in depth reply, that really helps a lot!

I'm working on getting the code that you posted to work now, I keep getting
Compile error:
User-defined type not defined
and it highlights "olApp As Outlook.Application" near the top in blue and then highlights "Sub Create_Appointment()" at the very top in yellow.
 
Upvote 0
Next question, if I have separate date and time fields how do I combine them for the start and end times? I've tried a few things but nothings working..
 
Upvote 0
Add them, as shown in your first macro:

.Start = arrAppt(i, 1) + arrAppt(i, 2)

With my code, assuming A1 is the date and B1 contains the time, this gives:
Code: 
Sub Create_Appointment()

    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0

    Set olApt = olApp.CreateItem(olAppointmentItem)
    
    With olApt
        .Start = Range("A1").Value + Range("B1").Value
        .End = .Start + TimeValue("02:00")
        .Subject = Range("C1").Value
        .Location = Range("D1").Value
        .Body = Range("E1").Value
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 5
        .ReminderSet = True
        .Save
    End With

End Sub
and the End time, I've decided, is 2 hours later, but this can also come from a single cell or two cell values added together. I'm sure you get the picture - have a play around.
 
Upvote 0
i hope i am not robbing this thread. How could this code work if I wanted to use this code so that when I click on a specific cell say A5, A19 or A100 and I run the macro the calendar event would pull att the pertinent information from that specific row?
 
Upvote 0
Try something like this:
Code: 
Sub Create_Appointment()

    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Dim row As Long
    
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If olApp Is Nothing Then
        Set olApp = New Outlook.Application
    End If
    On Error GoTo 0

    Set olApt = olApp.CreateItem(olAppointmentItem)
    
    row = ActiveCell.row
    
    With olApt
        .Start = Cells(row, 1).Value + Cells(row, 2).Value
        .End = .Start + TimeValue("02:00")
        .Subject = Cells(row, 3).Value
        .Location = Cells(row, 4).Value
        .Body = Cells(row, 5).Value
        .BusyStatus = olBusy
        .ReminderMinutesBeforeStart = 5
        .ReminderSet = True
        .Save
    End With

End Sub
 
Upvote 0
I would recommend appending John's code with a boolean check of Outlook, to close if you opened it (you had it in your initial code).
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Macro to Generate Reminder in Outlook Calendar
Replies
3
Views
1K
Micron
M
B
  • Question
Macro to open a new email via Outlook
Replies
3
Views
261
skillilea
S
B
  • Question
Excel VBA create appointments for 13th of Month or next working day
Replies
9
Views
894
Biz
B
L
  • Question
VBA query - not opening outlook email but one drive
Replies
0
Views
168
Liverlee
L
R
  • Question
VBA to run macro with the most recent events
Replies
4
Views
169
rafaelbatalha
R

Forum statistics

Threads
1,214,634
Messages
6,120,659
Members
448,975
Latest member
sweeberry

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top