Count Outlook emails by Category for a specified date.

[JazzSP8]

Hey All

I've been asked to come up with way to count emails in various shared mailboxes, by category (person who dealt with them) and for certain dates.

I found this code, https://www.mrexcel.com/forum/excel-questions/660328-count-how-many-emails-each-colour-category.html, which did the trick nicely when it come to the categories (I'll take the time to say "Thanks Domenic!").

I found some more code that counted the emails in an inbox so I tried to merge the two and came up with this;

Sub CountEmails()
''' Requires Microsoft Outlook Object Library and Microsoft Scripting Runtime to be Enabled

    Dim oDict As Scripting.Dictionary
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object
    Dim arrData() As Variant
    Dim CategoryCnt As Integer
    Dim c As Long
    Dim dateStr, dateChk As String
    
    Set oDict = New Scripting.Dictionary
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set objFolder = olNS.Folders(Cells(1, "A").Value)
    Set objFolder = objFolder.Folders("Inbox")
    
    Set myItems = objFolder.Items
    myItems.SetColumns ("SentOn")
    
    dateChk = Cells(1, "B").Value
    
    CategoryCnt = olNS.Categories.Count
    
    ReDim arrData(1 To 2, 1 To CategoryCnt)
    
    c = 0
    For Each olItem In objFolder.Items
        dateStr = GetDate(olItem.SentOn)
        
        If dateStr = dateChk Then
        
            If Not oDict.Exists(olItem.Categories) Then
                c = c + 1
                arrData(1, c) = olItem.Categories
                arrData(2, c) = 1
                oDict.Add olItem.Categories, c
            Else
                arrData(2, oDict.Item(olItem.Categories)) = arrData(2, oDict.Item(olItem.Categories)) + 1
            End If
        
        End If
    Next olItem
    
    ReDim Preserve arrData(1 To 2, 1 To c)
    
    Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = Application.Transpose(arrData)
    
End Sub

Function GetDate(dt As Date) As String
    GetDate = Day(dt) & "/" & Month(dt) & "/" & Year(dt)
End Function

The problem seems to occour when the dates match, I verified this with some test code at an earlier point before it triggers. I get a "Subscript out of range" error.

If I comment out the "If dateStr = dateChk Then" and it's "End if" then the code runs and does it's job as it would do without the date check but then I just get the total for each category.

I've tried setting a break point on "If Not oDict.Exists(olItem.Categories) Then" to see if I can find out what the problem is but it just errors out.

Can anyone help?

Thanks

 

[John_w]

Are dateStr and dateChk in the same date format?

Try these changes:

    dateChk = Format(Cells(1, "B").Value, "dd/mm/yyyy")


Function GetDate(dt As Date) As String
    GetDate = Format(dt, "dd/mm/yyyy")
End Function

 

[JazzSP8]

Yes! That worked! - I hadn't thought to check or force them into the right format because I was getting a match so just assumed they where and got bogged down in other details.

Brilliant, thank you very much for that!