1. Some things are too good not to share

  2. This is one of them

  3. How about if I show you how to take rows in Excel and make them appointments in Outlook?

  4. Well then, you must read on

Outlook appointments

  1. Managing your calendar is a critical success factor at almost any company

  2. If I can automate anything I will spend the time to do it

  3. This utility has served me well over the years

    image001

    Figure 1: Excel to Outlook

IT IS SOME SIMPLE VBA CODE

  1. It is a simple question of taking cells in Excel and making them properties in an Outlook appointment

  2. Just write a loop in VBA and go through all the rows in Excel and writes appointments in Excel

HERE IS WHAT THE CODE LOOKS LIKE

  1. There are endless possibilities here

    • You could invite attendees
    • You could add attachments
Excel VBA
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Sub RegisterAppointmentList()
    ' adds a list of appontments to the Calendar in Outlook
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
   
    On Error Resume Next
    Worksheets("Schedule").Activate

    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    r = 6 ' first row with appointment data in the active worksheet
    Dim mysub, myStart, myEnd
    While Len(Cells(r, 2).Text) <> 0
        mysub = Cells(r, 2) & ", " & Cells(r, 3)
        myStart = DateValue(Cells(r, 5).Value) + Cells(r, 6).Value
        myEnd = DateValue(Cells(r, 5).Value) + Cells(r, 7).Value
        'DeleteTestAppointments mysub, myStart, myEnd
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
            ' set default appointment values
            .Location = Cells(r, 3)
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            '.RequiredAttendees = "johndoe@microsoft.com"
            On Error Resume Next
            .Start = myStart
            .End = myEnd
            .Subject = Cells(r, 2) & ", " & .Location
            .Attachments.Add ("c:\temp\somefile.msg")
            .Location = Cells(r, 3).Value
            .Body = .Subject & ", " & Cells(r, 4).Value
            .ReminderSet = True
            .BusyStatus = olBusy
            .Categories = "Orange Category" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
    MsgBox "Done !"
End Sub