How to count hours/days/weeks spent on an appointment or meeting in Outlook?
Let’s say there are lots of appointments and meetings in a calendar in Outlook. And now you want to count the hours/days/weeks spent on these appointments and meetings, any idea? This article will introduce a VBA to help you.
This method will introduce a VBA to count the hours or minutes spent on the specified appointment or meeting in Outlook. Please do as follows:
1. Shift to the Calendar folder, and click to select the appointment or meeting which you will count spent hours.
2. Press Alt + F11 keys simultaneously to open the Microsoft Visual Basic for Applications window.
3. Click Insert > Module, and then paste below VBA code into the opening Module window.
VBA: Count hours/minutes spent on an appointment or meeting in Outlook
Sub CountTimeSpent() Dim oOLApp As Outlook.Application Dim oSelection As Outlook.Selection Dim oItem As Object Dim iDuration As Long Dim iTotalWork As Long Dim iMileage As Long Dim iResult As Integer Dim bShowiMileage As Boolean bShowiMileage = False iDuration = 0 iTotalWork = 0 iMileage = 0 On Error Resume Next Set oOLApp = CreateObject("Outlook.Application") Set oSelection = oOLApp.ActiveExplorer.Selection For Each oItem In oSelection If oItem.Class = olAppointment Then iDuration = iDuration + oItem.Duration iMileage = iMileage + oItem.Mileage ElseIf oItem.Class = olTask Then iDuration = iDuration + oItem.ActualWork iTotalWork = iTotalWork + oItem.TotalWork iMileage = iMileage + oItem.Mileage ElseIf oItem.Class = Outlook.olJournal Then iDuration = iDuration + oItem.Duration iMileage = iMileage + oItem.Mileage Else iResult = MsgBox("Please select some Calendar, Task or Journal items at first!", vbCritical, "Items Time Spent") Exit Sub End If Next Dim MsgBoxText As String MsgBoxText = "Total time spent: " & vbNewLine & iDuration & " minutes" If iDuration > 60 Then MsgBoxText = MsgBoxText & HoursMsg(iDuration) End If If iTotalWork > 0 Then MsgBoxText = MsgBoxText & vbNewLine & vbNewLine & "Total work recorded; " & vbNewLine & iTotalWork & " minutes" If iTotalWork > 60 Then MsgBoxText = MsgBoxText & HoursMsg(iTotalWork) End If End If If bShowiMileage = True Then MsgBoxText = MsgBoxText & vbNewLine & vbNewLine & "Total iMileage; " & iMileage End If iResult = MsgBox(MsgBoxText, vbInformation, "Items Time spent") ExitSub: Set oItem = Nothing Set oSelection = Nothing Set oOLApp = Nothing End Sub Function HoursMsg(TotalMinutes As Long) As String Dim iHours As Long Dim iMinutes As Long iHours = TotalMinutes \ 60 iMinutes = TotalMinutes Mod 60 HoursMsg = " (" & iHours & " Hours and " & iMinutes & " Minutes)" End Function
4. Press the F5 key or click the Run button to run this VBA.
And now a dialog box pops out and shows how many hours/minutes the selected appointment/meeting spent. See screenshot:
Note: You can select multiple appointments or meetings at the same time to count total hours/minutes spent on them with this VBA code.
Best Office Productivity Tools
Kutools for Outlook - Over 100 Powerful Features to Supercharge Your Outlook
📧 Email Automation: Out of Office (Available for POP and IMAP) / Schedule Send Emails / Auto CC/BCC by Rules When Sending Email / Auto Forward (Advanced Rules) / Auto Add Greeting / Automatically Split Multi-Recipient Emails into Individual Messages ...
Over 100 Features Await Your Exploration! Click Here to Discover More.