Count Emails By Date (Public)

PHOTO EMBED

Thu Aug 05 2021 22:39:26 GMT+0000 (Coordinated Universal Time)

Saved by @cnewnham #vba

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 

    Next 

 

    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 

    Next 

  

    objExcelWorksheet.Columns("A:B").AutoFit 

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 = "you@datanumen.com" Then 

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

  

              If objDictionary.Exists(strMonth) Then 

                 objDictionary(strMonth) = objDictionary(strMonth) + 1 

              Else 

                 objDictionary.Add strMonth, 1 

              End If 

           End If 

       End If 

    Next 

End Sub 
content_copyCOPY