In Outlook, contact has a separate “Activities” pane, where you can check all items associated with this contact. You may wish to export these activities. But no such a native function supports it. Thus, this post will introduce you a method to realize it.
To check all items related to a specific contact, you can simply access the contact “Activities” page. However, by default, Outlook doesn’t support you to export the activity list. Hence, if you wish to quickly export it, you can use the way shared in the followings.
Export the Activities of a Specific Contact to Excel
- At the very outset, start your Outlook application.
- Then, in its main window, you could press “Alt + F11” key buttons.
- After that, a new window called “Microsoft Visual Basic for Applications” will display, where you need to open an unused module or just insert a new one.
- Next, you ought to copy the following VBA code into this module.
Dim objExcelApp As Excel.Application Dim objExcelWorkbook As Excel.Workbook Dim objExcelWorksheet As Excel.Worksheet Dim objContact As ContactItem Sub ExportContactActivitiesToExcel() Dim objStore As Store Dim objPSTFile As Folder Set objContact = Application.ActiveExplorer.Selection.Item(1) If Not (objContact Is Nothing) Then 'Create a new Excel workbook 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, 1).Font.Bold = True .Cells(1, 1).Font.Size = 14 .Cells(1, 2) = "In Folder" .Cells(1, 2).Font.Bold = True .Cells(1, 2).Font.Size = 14 End With 'Process all PST files in your Outlook For Each objStore In Application.Session.Stores Set objPSTFile = objStore.GetRootFolder Call ProcessFolders(objPSTFile.Folders) Next objExcelWorksheet.Columns("A:B").AutoFit End If End Sub Sub ProcessFolders(ByVal objFolders As Folders) Dim objFolder As Folder Dim strFilter As String Dim objFoundItems As Items Dim objItem As Object Dim objLink As Link Dim objRecipient As recipient 'Process all folders recursively For Each objFolder In objFolders Select Case objFolder.DefaultItemType Case olMailItem 'Find related emails objFolder.Items.SetColumns ("From, To, CC") strFilter = "[From] =" & Chr(34) & objContact.Email1Address & Chr(34) & " OR" & " [To] =" & Chr(34) & objContact.Email1Address & Chr(34) & " OR " & "[CC] =" & Chr(34) & objContact.Email1Address & Chr(34) If objContact.Email2Address <> "" Then strFilter = strFilter & " OR [From] =" & Chr(34) & objContact.Email2Address & Chr(34) & " OR" & " [To] =" & Chr(34) & objContact.Email2Address & Chr(34) & " OR" & " [CC] =" & Chr(34) & objContact.Email2Address & Chr(34) End If If objContact.Email3Address <> "" Then strFilter = strFilter & " OR [From] =" & Chr(34) & objContact.Email3Address & Chr(34) & " OR" & " [To] =" & Chr(34) & objContact.Email3Address & Chr(34) & " OR" & " [CC] =" & Chr(34) & objContact.Email3Address & Chr(34) End If Set objFoundItems = objFolder.Items.Restrict(strFilter) 'Export to Excel For Each objItem In objFoundItems Call ExportToExcel(objFolder, objItem) Next 'Export related tasks and journals Case olTaskItem, olJournalItem For Each objItem In objFolder.Items For Each objLink In objItem.links If objLink.Name = objContact.FullName Then Call ExportToExcel(objFolder, objItem) End If Next Next 'Export related appointments Case olAppointmentItem For Each objItem In objFolder.Items If objItem.Recipients.Count > 0 Then For Each objRecipient In objItem.Recipients If objRecipient.Address = objContact.Email1Address Or objRecipient.Address = objContact.Email2Address Or objRecipient.Address = objContact.Email3Address Then Call ExportToExcel(objFolder, objItem) End If Next Else For Each objLink In objItem.links If objLink.Name = objContact.FullName Then Call ExportToExcel(objFolder, objItem) End If Next End If Next End Select Call ProcessFolders(objFolder.Folders) Next End Sub Sub ExportToExcel(objCurrentFolder As Folder, objCurrentItem As Object) Dim nLastRow As Integer nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1 'Input item's subject as well as current folder path objExcelWorksheet.Range("A" & nLastRow) = objCurrentItem.Subject objExcelWorksheet.Range("B" & nLastRow) = objCurrentFolder.FolderPath End Sub
- After that, you could exit the current window.
- Subsequently, add the new macro to Quick Access Toolbar as normal.
- Finally you can have a try.
- Firstly, select a contact in your Contacts folder.
- Then click on the macro button in Quick Access Toolbar.
- After the macro finishes, you will see a new Excel workbook, in which all of this contact’s activities have been listed out, like the screenshot below:
Retrieve Corrupt Outlook Data
Outlook is prone to damage though it comes endowed with many functions. So in order to protect your Outlook data, you’d better make regular backups. Moreover, it is prudent to keep a reliable and formidable repair tool handy, like DataNumen Outlook Repair. It can recover PST data like a cork.
Shirley Zhang is a data recovery expert in DataNumen, Inc., which is the world leader in data recovery technologies, including sql corruption and outlook repair software products. For more information visit www.datanumen.com