Sub GetAppointments()

Dim myApp As New Outlook.Application
Dim myNS As NameSpace
Dim myFolder As MAPIFolder 'Outlooks MAPI folders e.g. Inbox, Contacts, Calendar
Dim myItems As Items 'each mail item
Dim MyItem As AppointmentItem 'for the individual appointments
Dim intLoopCounter As Integer, intBusy As Integer

Set myNS = myApp.GetNamespace("MAPI") 'get a namespace for the data items in the MAPI
Set myFolder = myNS.GetDefaultFolder(olFolderCalendar) 'set the folder as the calendar
Set myItems = myFolder.Items ' set the myItems to be each of the appointments in the calendar data space

For intLoopCounter = 2 To myItems.Count ' Loop through all the appointments in the calendar
' We could have a line in her to check if the appointment is past a certain date and only return such items e.g.
' If myItems(intLoopCounter).Start > "Date" then
Range("a" & intLoopCounter).Value = myItems(intLoopCounter).Subject ' set the value of the cell A and the loop position to the subject of the appointment
Range("b" & intLoopCounter).Value = myItems(intLoopCounter).Start ' set the value of the cell B and the loop position to the start date/time value of the appointment
Range("c" & intLoopCounter).Value = myItems(intLoopCounter).End ' set the value of the cell C and the loop position to the end date/time of the appointment
Select Case myItems(intLoopCounter).BusyStatus ' now we need to know what the value of the status is using the select case of the .BusyStatus
Case 0
Range("d" & intLoopCounter).Value = "Free" ' and depending on its value, write this to the cell D and the loop position
Case 1
Range("d" & intLoopCounter).Value = "Tentative"
Case 2
Range("d" & intLoopCounter).Value = "Busy"
Case 3
Range("d" & intLoopCounter).Value = "Out of Office"
End Select
Range("e" & intLoopCounter).Value = myItems(intLoopCounter).Location ' set the value of the cell E and the loop position to the Location of the appointment
' End If '- uncomment this line if you are using the date check line above
Next intLoopCounter ' Iterate through to the next appointment item

Set myNS = Nothing ' always clear up after!
Set myFolder = Nothing
Set myItems = Nothing
Set MyItem = Nothing

End Sub