I use the code below to count emails by Sender and send to a new Excel sheet. I would like one that will count emails in the inbox by subject line, excluding characters at the beginning (e.g. {EXTERNAL}, RE:, FW:, etc.), and send those to a new Excel sheet. Any suggestions?
VBA Code:
Sub CountInboxEmailsbySender()
Dim objDictionary As Object
Dim objInbox As Outlook.Folder
Dim i As Long
Dim objMail As Outlook.MailItem
Dim strSender As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim varSenders As Variant
Dim varItemCounts As Variant
Dim nLastRow As Integer
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
For i = objInbox.Items.Count To 1 Step -1
If objInbox.Items(i).Class = olMail Then
Set objMail = objInbox.Items(i)
strSender = objMail.SenderEmailAddress
If objDictionary.Exists(strSender) Then
objDictionary.Item(strSender) = objDictionary.Item(strSender) + 1
Else
objDictionary.Add strSender, 1
End If
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) = "Sender"
.Cells(1, 2) = "Count"
End With
varSenders = objDictionary.Keys
varItemCounts = objDictionary.Items
For i = LBound(varSenders) To UBound(varSenders)
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
With objExcelWorksheet
.Cells(nLastRow, 1) = varSenders(i)
.Cells(nLastRow, 2) = varItemCounts(i)
End With
Next
objExcelWorksheet.Columns("A:B").AutoFit
End Sub
