How to Auto Export the Time Spent on Each Appointment of Last Week in Outlook

Many users are used to creating a report of time spent on their weekly schedules, such as weekly appointments. Now, this article will teach how to let Outlook auto export the time spent on each appointment of last week every Monday.

For some reasons, like summarizing your weekly schedules and works, you may hope that Outlook can automatically count and export the time you spend on each appointment of last week every Monday. Now, the method below will help you realize it.

Auto Export the Time Spent on Each Appointment of Last Week in Outlook

Auto Export the Time Spent on Each Appointment of Last Week

  1. At the very outset, launch your Outlook program.
  2. Then, in the Outlook window, press “Alt + F11” keys to access VBA editor.
  3. In the subsequent “Microsoft Visual Basic for Applications” window, you can open the “ThisOutlookSession” project.
  4. Next, copy the VBA code below into this project.
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim nLastRow As Integer
Dim lTotalDuration As Long

Private Sub Application_Reminder(ByVal Item As Object)
    If TypeOf Item Is TaskItem And Item.Subject = "Weekly Appointment Report" Then
       'Check if the current date is Monday
       If Weekday(Date) = 2 Then
          'Create a new Excel file
          Set objExcelApp = CreateObject("Excel.Application")
          Set objExcelWorkbook = objExcelApp.Workbooks.Add
          Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
          objExcelApp.Visible = True
          With objExcelWorksheet
               .Cells(1, 1) = "Subject"
               .Cells(1, 2) = "Start"
               .Cells(1, 3) = "End"
               .Cells(1, 4) = "Duration"
         End With
         Call FindLastWeekAppointments
         nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 2
         'Record the total time spent on all appointments of last week
         objExcelWorksheet.Range("A" & nLastRow) = "Total Duration:"
         objExcelWorksheet.Range("B" & nLastRow) = (lTotalDuration \ 60) & " h " & (lTotalDuration Mod 60) & " min"
       End If
    End If
End Sub

Private Sub FindLastWeekAppointments()
    Dim objAppointments As Outlook.Items
    Dim strFilter As String
    Dim objLastWeekAppointments As Outlook.Items
    Dim objAppointment As Outlook.AppointmentItem
    Dim strSubject As String
    Dim dStart, dEnd As Date
    Dim lDuration As Long
    'Find the appointments of last week
    Set objAppointments = Application.Session.GetDefaultFolder(olFolderCalendar).Items
    strFilter = "[Start] <= " & Chr(34) & (Date - 1) & " 11:59 PM" & Chr(34) & " AND [End] >= " & Chr(34) & (Date - 7) & " 00:00 AM" & Chr(34)
    Set objLastWeekAppointments = objAppointments.Restrict(strFilter)
    lDuration = 0
    lTotalDuration = 0
    If objLastWeekAppointments.Count > 0 Then
       For Each objAppointment In objLastWeekAppointments
           'Exclude birthdays, anniversaries and holidays
           If InStr(objAppointment.Subject, "Birthday") = 0 And InStr(objAppointment.Subject, "Anniversary") = 0 And InStr(objAppointment.Categories, "Holiday") = 0 Then
              strSubject = objAppointment.Subject
              dStart = objAppointment.start
              dEnd = objAppointment.End
              lDuration = objAppointment.Duration
              'Export the details to Excel
              Call ExportToExcel(strSubject, dStart, dEnd, lDuration)
              'Get the total time spent
              lTotalDuration = lDuration + lTotalDuration
           End If
    End If
End Sub

Private Sub ExportToExcel(strSubject, dStart, dEnd, lDuration)
    nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
    objExcelWorksheet.Range("A" & nLastRow) = strSubject
    objExcelWorksheet.Range("B" & nLastRow) = dStart
    objExcelWorksheet.Range("C" & nLastRow) = dEnd
    'Convert minutes to hours
    If lDuration > 60 Then
       objExcelWorksheet.Range("D" & nLastRow) = (lDuration \ 60) & " h " & (lDuration Mod 60) & " min"
       objExcelWorksheet.Range("D" & nLastRow) = lDuration & " min"
    End If
End Sub

VBA Code - Auto Export the Time Spent on Each Appointment of Last Week

  1. After that, you ought to sign this code and exit the current window.
  2. Later, access Tasks area and create a recurring task with a reminder enabled.
  • Click “New Task” button in ribbon.
  • Then input “Weekly Appointment Report” in the subject line.
  • Next click “Recurrence” button in ribbon.
  • In the dialog box, set “weekly Monday with no end date” recurrence.
  • After that, enable a reminder on every Monday as per your needs.
  • Lastly, save this task by “Save & Close” button.Create a recurring task with a reminder enabled
  1. From now on, every time when this task reminder fires, the previously added subroutine will be triggered. An Excel file which is logging the time spent on each appointment of last week will display, like the screenshot below:Exported Excel file

What If Inbuilt Repair Tool Fails?

Outlook comes with an inbox fix tool – Scanpst. It is pretty useful in the event of small issues. If what you’re meeting is considerably serious Outlook corruption, it will not be helpful. Therefore, at this point, you have no alternative but to take aid of an external repair tool such as DataNumen Outlook Repair or take recourse to a professional recovery service.

Author Introduction:

Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including corrupted sql and outlook repair software products. For more information visit

Comments are closed.