Count Emails in Folder/Subfolder in Current Month

[hmltnangel]

OK, cross post - but no reply on Mr Excel. So I thought I would ask here.

I need some VBA to count the emails in a shared mailbox for the current month.

This code here, works well but shows things by month only, and the order of the months is out. Can someone please help change so it shows by month (in the correct order), and subfolder?

For Example

Subfolder
2019-12 - number of emails
2020-1 - number of emails

Subfolder 2
2019-11 - number of emails
2019-12 - number of emails
2020-1 - number of emails

etc etc

Sub HowManyEmails()

    Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
    Dim EmailCount As Integer
    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")


        On Error Resume Next
        Set objFolder = Application.Session.PickFolder
        If Err.Number <> 0 Then
        Err.Clear
        MsgBox "No such folder."
        Exit Sub
        End If


    EmailCount = objFolder.Items.Count


    MsgBox "Number of emails in the folder: " & EmailCount, , "email count"


    Dim dateStr As String
    Dim myItems As Outlook.Items
    Dim dict As Object
    Dim msg As String
    Set dict = CreateObject("Scripting.Dictionary")
    Set myItems = objFolder.Items
    myItems.SetColumns ("SentOn")
    ' Determine date of each message:
    For Each myItem In myItems
        dateStr = GetDate(myItem.SentOn)
        If Not dict.Exists(dateStr) Then
            dict(dateStr) = 0
        End If
        dict(dateStr) = CLng(dict(dateStr)) + 1
    Next myItem


    ' Output counts per day:
    msg = ""
    For Each o In dict.Keys
        msg = msg & o & ": " & dict(o) & " items" & vbCrLf
    Next
    MsgBox msg


    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
End Sub


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