Count Outlook emails by Sender & date in Excel VBA - vba

Question

The objective is to find the total/count of emails from Sender on Monthly basis.
The below code retrieves Date/Time for a count by month.
How to display by SenderName on the worksheet?
I'm not sure if I've to use two dictionaries? If yes no knowledge about how to work around it.
Sub ReferSpecificFolder()
'Declare Outlook application & folder object variables.
Dim objOutlook as Object, objnSpace as Object, objFolder As Outlook.MAPIFolder
Dim olItem As Variant 'Object
Dim dictDate as Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace=objOutlook.GetNamespace("MAPI")
Set objFolder = objOutlook.GetNamespace("MAPI").Folders("xyz#microsoft.com").Folders("Sales - 2020")
Set dictDate=CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
On Error Resume Next
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder!"
Exit Sub
End If
If fldr.Items.Count = 0 Then
MsgBox "There were no messages found in your folders"
Exit Sub
End If
'Select the sheet to enter the data
Dim wbData As Worksheet
Dim LastRow As Long
Set wbData = ThisWorkbook.Sheets("Rawdata - Time Period")
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
myItems.SetColumns("SenderName, SentOn")
For Each i In myItems
dateStr=GetDate(i.SentOn)
strSender=i.SenderName
If Not dictDate.Exists(dateStr) Then
dictDate(dateStr)=0
End If
dictDate(dateStr)=CLng(dictDate(dateStr))+1
Next i
For Each o In dictDate.keys
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
With wbData
.Cells(LastRow, 1) = o 'Received Date
.Cells(LastRow, 3) = dictDate(o) 'Count
End With
Next o
Set fldr = Nothing
Set olItem = Nothing
Set olApp = Nothing
MsgBox "DONE!"
End Sub
Function GetDate(dt as Date) as String
GetDate=Year(dt) & "-" & Month(dt) & "-" & Day(dt) & " " & Hour(dt) & ":" & Minute(dt)
End Function

Answer 1

This generates a single sender dictionary then a date dictionary corresponding to each entry in the sender dictionary.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
'
' If desperate declare as Variant
'
Sub ReferSpecificFolderSender()
' Early binding, must set a reference to
' Microsoft Outlook XX.X Object Library
Dim objOutlook As Outlook.Application
Dim objnSpace As Outlook.Namespace
Dim objFolder As Outlook.Folder
Dim olItemI As Object
Dim olItemJ As Object
Dim myItems As Outlook.Items
Dim myItemsDate As Outlook.Items
Dim strFilter As String
Dim dictDate As Object
Dim o As Variant
Dim dateStr As String
Dim dictSender As Object
Dim p As Variant
Dim strSender As String
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
' For the specific purpose of addressing an expected error
' due to not finding objFolder
On Error Resume Next
Set objFolder = objnSpace.Folders("xyz#microsoft.com").Folders("Sales - 2020")
If Err.Number <> 0 Then
Err.Clear
'MsgBox "No such folder!"
'Exit Sub
Set objFolder = objnSpace.PickFolder
If objFolder Is Nothing Then Exit Sub
End If
' Consider mandatory to closely follow On Error Resume Next
' Return to normal error handling
On Error GoTo 0
Set myItems = objFolder.Items
Debug.Print vbCr & "myItems.Count: " & myItems.Count
If objFolder.Items.Count = 0 Then
MsgBox "There were no messages found in " & objFolder.FolderPath
Exit Sub
End If
Set dictSender = CreateObject("Scripting.Dictionary")
' Restrict to mailitems
' 0x001A001F
' https://stackoverflow.com/questions/61793354/delete-items-in-outlook-by-type-or-message-class
'strFilter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x001A001F"" LIKE 'IPM.Note'"
'Set myItems = myItems.Restrict(strFilter)
' 0x001A001E
' "PR_MESSAGE_CLASS" http://schemas.microsoft.com/mapi/proptag/0x001A001E
' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
strFilter = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x001A001E"" LIKE 'IPM.Note'"
Set myItems = myItems.Restrict(strFilter)
Debug.Print vbCr & "Mailitems"
Debug.Print "myItems.Count: " & myItems.Count
myItems.Sort "[SenderName]", False
Set dictDate = CreateObject("Scripting.Dictionary")
Set myItemsDate = myItems
Debug.Print "myItemsDate.Count: " & myItemsDate.Count
'The sheet to enter the data
Dim wbData As Worksheet
Dim LastRow As Long
Set wbData = ThisWorkbook.Sheets("Rawdata - Time Period")
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
' dictionary of sender names
Debug.Print "Sender dictionary"
' With the SetColumns method, Outlook only checks the properties that you have cached,
' and provides fast, read-only access to these properties.
' https://learn.microsoft.com/en-us/office/vba/api/outlook.items.setcolumns
myItems.SetColumns ("SenderName")
For Each olItemJ In myItems
strSender = olItemJ.SenderName
If Not dictSender.Exists(strSender) Then
Debug.Print " " & strSender
dictSender(strSender) = 0
End If
dictSender(strSender) = CLng(dictSender(strSender)) + 1
Next
' iterate unique sender names
For Each p In dictSender.keys
Debug.Print "Date dictionary for: " & p
myItems.Sort "[SentOn]", False
myItemsDate.SetColumns ("SenderName, SentOn")
' check item's date against the sender name dictionary
For Each olItemI In myItemsDate
strSender = olItemI.SenderName
If strSender = p Then
' unique dates for current SenderName
dateStr = GetDate(olItemI.SentOn)
If Not dictDate.Exists(dateStr) Then
dictDate(dateStr) = 0
End If
' count of ccurrences for each date
dictDate(dateStr) = CLng(dictDate(dateStr)) + 1
End If
Next
For Each o In dictDate.keys
LastRow = wbData.Range("A" & wbData.Rows.Count).End(xlUp).Row + 1
With wbData
.Cells(LastRow, 1) = p ' SenderName
.Cells(LastRow, 2) = o ' GetDate value
.Cells(LastRow, 3) = dictDate(o) ' Count
End With
Next
' delete date dictionary entries for current SenderName
dictDate.RemoveAll
Next p
ActiveSheet.Columns.AutoFit
Set objFolder = Nothing
Set olItemI = Nothing
Set olItemJ = Nothing
Set objOutlook = Nothing
Set objnSpace = Nothing
Set dictSender = Nothing
Set dictDate = Nothing
Set myItemsDate = Nothing
Debug.Print "DONE!"
'MsgBox "DONE!"
End Sub