Outlook Calendar To Excel

I need to produce a weekly report detailing what work I have carried out. I diligently record this in my Outlook calendar. My weekly report needs to be submitted in Microsoft Excel.

The following macro will pull the entries for the last seven days from my calendar and store it in Excel format.

Sub generateTimesheet()
    Dim OlApp As Outlook.Application
    Dim OlNameSpace As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim olAppointments As Object
    Dim olItems, olFinalItems As Outlook.Items
    Dim olAppointmentItem As Outlook.AppointmentItem
    Dim dtStart, dtEnd As Date
    Dim strRestriction As String
    
    dtStart = Format(Date - 7, "dd/mm/yyyy hh:mm AMPM")
    dtEnd = Format(Date + 1, "dd/mm/yyyy hh:mm AMPM")
    strRestriction = "[Start] >= '" & dtStart & "' AND [Start] <= '" & dtEnd & "'"
    
    Set OlApp = New Outlook.Application
    Set OlNameSpace = OlApp.GetNamespace("MAPI")
    Set olAppointments = OlNameSpace.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderCalendar)
    Set olItems = olAppointments.Items
    olItems.IncludeRecurrences = True
    olItems.Sort "[Start]"
    Set olFinalItems = olItems.Restrict(strRestriction)
    Excel.ActiveWorkbook.ActiveSheet.Range("a2", Range("a2").End(xlDown).End(xlToRight)).Select
    Selection.Clear
    For Each olAppointmentItem In olFinalItems
        If Excel.ActiveWorkbook.ActiveSheet.Range("a2").Value = "" Then
            Excel.ActiveWorkbook.ActiveSheet.Range("a2").Select
        Else
            Excel.ActiveWorkbook.ActiveSheet.Range("a1").End(xlDown).Offset(1, 0).Select
        End If
'        ActiveCell.Value = Format(olAppointmentItem.Start, "dd/mm/yyyy")
        ActiveCell.Offset(0, 0).Value = Format(olAppointmentItem.Start, "Dddd")
        ActiveCell.Offset(0, 1).Value = Format(olAppointmentItem.Start, "Medium Date")
        ActiveCell.Offset(0, 2).Value = olAppointmentItem.Subject
        ActiveCell.Offset(0, 3).Value = Format(olAppointmentItem.Start, "hh:mm:ss")
        ActiveCell.Offset(0, 4).Value = olAppointmentItem.Duration
    Next
    Excel.ActiveWorkbook.ActiveSheet.Range("a1").Select
    
End Sub

https://github.com/RossGoodman/Excel/blob/master/CalendarToExcel

This macro should be placed in an excel spreadsheet and from there it will connect to Microsoft Outlook.

Stepping through the code:

• Get the dates for seven days ago and today then build a restriction clause to filter the calendar.
• Create a connection to my default calendar, sort the events by start date and apply the restriction on the dates.
• Clear the contents of the current worksheet – from A2 to the bottom right.
• Loop through each calendar entry
• Use either A2 or the first empty row below A2
• Write the relevant calendar attributes in the appropriate format on the selected row.
• End Loop
• Set the cursor to the top of the sheet.

Any problems, comments or suggestions for other macros/tips; let me know in the comments below.