Counting emails using excel VBA - vba

Question

First time posting - hopefully I am clear enough.
I'm not that expirienced with excel VBA, but have managed to find and change (with the help of my IT area) some code through these forums that counts the number of emails in outlook folders by a date in a cell. The code works fine when counting emails in one folder. What I need the code to do is count the emails in numerous folders (of which the list is stored in a sheet in the workbook) and output the count into seperate columns. (was hoping to post a picture as an example but I need a higher rep!)
Here is the code I have so far:
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim myCell As Object
Dim dictEmailDates As New Scripting.Dictionary
Dim folder1 As String, folder2 As String, folder3 As String
folder1 = Sheets("Sheet1").Cells.Cells(2, 5)
folder2 = Sheets("Sheet1").Cells.Cells(2, 6)
folder3 = Sheets("Sheet1").Cells.Cells(2, 7)
' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(folder1)
If Not IsEmpty(folder2) Then
Set objFolder = objFolder.Folders(folder2)
End If
If Not IsEmpty(folder3) Then
Set objFolder = objFolder.Folders(folder3)
End If
If Err.Number <> 0 Then
Err.Clear
MsgBox "Folder doesn't exist. Please ensure you have input the correct folder details."
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
Exit Sub
End If
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
CountEmails objFolder, dictEmailDates
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to active cell
Sheets("Sheet1").Range("A2").Select
Do Until IsEmpty(ActiveCell)
DateCount = 0
myDate = ActiveCell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
Selection.Offset(0, 1).Activate
ActiveCell.Value = DateCount
Selection.Offset(1, -1).Activate
Loop
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
EmailCount = objFolder.Items.Count
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub
Hoping someone can help?? If there is anything extra or if I need to explain myself more please let me know!
Cheers, Adrian

Answer 1

If I'm following, the issue is that folder1 (or 2 or 3) is the only folder being counted. The issue looks to be that you only ever load one folder into your dictionary (based on the code I would think it was folder3). I would address that by restructuring the code as follows (I also added some performance improvements and removed a bunch of stuff that looked to be doing nothing):
Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim myDate As Date
Dim dictEmailDates As New Scripting.Dictionary
Dim i As Integer
Dim dcell As Range 'refering to range saves you having to keep retyping range to use,
'reducing likelihood of typo
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'refering to ws saves having to type out
'Sheet1 each time, and also makes it easier to update code if sheet name ever changes
'Turn off screen updates for faster run
Application.ScreenUpdating = False
'Get the Outlook items setup
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
'Start looping through the folders
i = 0
Do Until IsEmpty(ws.Cells.Cells(2, 5 + i))
' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(ws.Cells.Cells(2, 5 + i))
'Get count of items and put in array based on ReceivedTimes
CountEmails objFolder, dictEmailDates
Loop
'Notice I completely removed Date and Folder count from this sub, they were only ever
'set here, not used. Looked like legacy code from attempting to perform the count in
'this sub rather than the self-referencing sub you created.
' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
' Count the emails dates equal to current cell
i = 2
Set dcell = ws.Range("A" & i)
Do Until IsEmpty(dcell)
DateCount = 0
myDate = dcell.Value
If dictEmailDates.Exists(myDate) Then
DateCount = dictEmailDates(myDate)
End If
dcell.Offset(0, 1).Value = DateCount
i = i + 1
Set dcell = ws.Range("A" & i)
Loop
Application.ScreenUpdating = True
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub
Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count
' Put ReceivedTimes in array
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
If dictEmailDates.Exists(dateKey) Then
dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
Else
dictEmailDates.Add dateKey, 1
End If
End With
Next iCount
For iCount = 1 To FolderCount
CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub