Scheduling Appointments in Outlook From Excel

  • Article

  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