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
- At the very outset, launch your Outlook program.
- Then, in the Outlook window, press “Alt + F11” keys to access VBA editor.
- In the subsequent “Microsoft Visual Basic for Applications” window, you can open the “ThisOutlookSession” project.
- 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 objExcelWorkbook.Activate 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" objExcelWorksheet.Columns("A:D").AutoFit End If Item.MarkComplete 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 Next 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" Else objExcelWorksheet.Range("D" & nLastRow) = lDuration & " min" End If End Sub
- After that, you ought to sign this code and exit the current window.
- 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.
- 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:
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.
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 www.datanumen.com