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