Count Outlook emails by Sender & date in Excel 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://docs.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