JazzSP8
Well-known Member
- Joined
- Sep 30, 2005
- Messages
- 1,233
- Office Version
- 365
- Platform
- Windows
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;
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
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;
Code:
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