Dim objDictionary As Object 


Sub CountSentMailsByMonth() 'Must enable Microsoft Excel Reference Library 

    Dim objOutlookFile As Outlook.Folder 

    Dim objFolder As Outlook.Folder 

    Dim objExcelApp As Excel.Aapplication 

    Dim objExcelWorkbook As Excel.Workbook 

    Dim objExcelWorksheet As Excel.Worksheet 

    Dim varMonths As Variant 

    Dim varItemCounts As Variant 

    Dim nLastRow As Integer 


    Set objDictionary = CreateObject("Scripting.Dictionary") 

    Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox) 


    'Get the default Outlook data file 

    Set objOutlookFile = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Parent 


    For Each objFolder In objOutlookFile.Folders 

        If objFolder.DefaultItemType = olMailItem Then 

           Call ProcessFolders(objFolder) 

        End If 



    Set objExcelApp = CreateObject("Excel.Application") 

    objExcelApp.Visible = True 

    Set objExcelWorkbook = objExcelApp.Workbooks.Add 

    Set objExcelWorksheet = objExcelWorkbook.Sheets(1) 


    With objExcelWorksheet 

        .Cells(1, 1) = "Month" 

        .Cells(1, 2) = "Count" 

    End With 


    varMonths = objDictionary.Keys 

    varItemCounts = objDictionary.Items 


    For i = LBound(varMonths) To UBound(varMonths) 

        nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1 

        With objExcelWorksheet 

            .Cells(nLastRow, 1) = varMonths(i) 

            .Cells(nLastRow, 2) = varItemCounts(i) 

        End With 




End Sub 


Sub ProcessFolders(ByVal objCurFolder As Outlook.Folder) 

    Dim i As Long 

    Dim objMail As Outlook.MailItem 

    Dim strMonth As String 


    For i = objCurFolder.Items.Count To 1 Step -1 

        If objCurFolder.Items(i).Class = olMail Then 

           Set objMail = objCurFolder.Items(i) 

           'Change to your own email address 

           If objMail.SenderEmailAddress = "" Then 

              strMonth = Format(Year(objMail.SentOn) & "-" & Month(objMail.SentOn), "YYYY/MM") 


              If objDictionary.Exists(strMonth) Then 

                 objDictionary(strMonth) = objDictionary(strMonth) + 1 


                 objDictionary.Add strMonth, 1 

              End If 

           End If 

       End If 


End Sub 
downloadDownload PNG downloadDownload JPEG downloadDownload SVG

Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!

Click to optimize width for Twitter