The following should give you the count of the selected folder and its sub-folders for the current month. If there are many sub-folders it could take a while to run.

Sub CountMail()
'Graham Mayor - https://www.gmayor.com - Last updated - 30 Aug 2020
Dim strCount As String
Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
    Set cFolders = New Collection
    Set olNS = GetNamespace("MAPI")
    cFolders.Add olNS.PickFolder
    strCount = "Mesaages for " & Format(Date, "mmmm yyyy") & vbCr & vbCr
    Do While cFolders.Count > 0
        Set olFolder = cFolders(1)
        cFolders.Remove 1
        strCount = strCount & olFolder.Name & vbTab & ProcessFolder(olFolder) & vbCr
        ' Debug.Print olfolder.Name & vbTab & olfolder.items.Count
        For Each SubFolder In olFolder.folders
            cFolders.Add SubFolder
        Next SubFolder
    Loop
    MsgBox strCount
lbl_Exit:
    Set olFolder = Nothing
    Set SubFolder = Nothing
    Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Function ProcessFolder(olFldr As Folder) As Integer
'Graham Mayor - https://www.gmayor.com - Last updated - 31 Aug 2020
Dim olItem As Object
Dim dDate As Date
Dim i As Integer, j As Integer
    j = 0
    olFldr.items.Sort "[Received]", True
    For i = olFldr.items.Count To 1 Step -1
        Set olItem = olFldr.items(i)
        dDate = Left(olItem.ReceivedTime, 10)
        If Month(dDate) = Month(Date) And Year(dDate) = Year(Date) Then
            j = j + 1
        Else
            Exit For
        End If
        DoEvents
    Next i
    ProcessFolder = j
lbl_Exit:
    Set olItem = Nothing
    Exit Function
End Function