Outlook VBA to count emails in inbox by Subject and send to an Excel spreadsheet

atdale

New Member
Joined
Dec 3, 2022
Messages
3
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
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
Try this macro and see if it works.

VBA Code:
Public Sub CountInboxEmailsBySubject()
    Dim objInboxFolder As Outlook.Folder
    Set objInboxFolder = Application.Session.PickFolder
    If Not objInboxFolder Is Nothing Then
        If objInboxFolder.DefaultItemType = olMailItem Then
            Dim strFilter As String
            Dim colItems As Outlook.Items
            Set colItems = objInboxFolder.Items
            If colItems.Count > 0 Then
                Dim i As Long
                Dim objXlApp As Excel.Application
                Dim objXlSh As Excel.Worksheet
                Dim objDic As Scripting.Dictionary
                Set objDic = New Scripting.Dictionary
                Dim strSubstring As String
                For i = 1 To colItems.Count
                    strSubstring = Left(colItems.Item(i).Subject, 10)
                    If InStr(strSubstring, "Fwd:") = 0 And _
                        InStr(strSubstring, "FW:") = 0 And _
                        InStr(strSubstring, "Re:") = 0 And _
                        InStr(strSubstring, "RE:") = 0 And _
                        InStr(strSubstring, "{EXTERNAL}") = 0 Then
                            If objDic.Exists(colItems.Item(i).Subject) Then
                                objDic.Item(colItems.Item(i).Subject) = objDic.Item(colItems.Item(i).Subject) + 1
                            Else: objDic.Add colItems.Item(i).Subject, 1
                            End If
                    End If
                Next
                Set objXlApp = New Excel.Application
                objXlApp.Visible = True
                objXlApp.Workbooks.Add
                Set objXlSh = objXlApp.Worksheets.Item("Sheet1")
                objXlApp.ScreenUpdating = False
                objXlSh.Range("A1").Value = "Subject"
                objXlSh.Range("B1").Value = "Count"
                For i = LBound(objDic.Keys) To UBound(objDic.Keys)
                    objXlSh.Range("A1").Offset(i + 1, 0).Value = objDic.Keys(i)
                    objXlSh.Range("B1").Offset(i + 1, 0).Value = objDic.Item(objDic.Keys(i))
                Next
                objXlApp.Range("A:B").Columns.AutoFit
                objXlApp.ScreenUpdating = True
            End If
        End If
    Else: Exit Sub
    End If
End Sub

For example, assume you want to count emails in inbox that do not contain any prefix like "Re:", "RE:", "Fwd:", "FW:", or "{EXTERNAL}, in Subject":
1679029991141.png
 
Upvote 0
Try this macro and see if it works.

VBA Code:
Public Sub CountInboxEmailsBySubject()
    Dim objInboxFolder As Outlook.Folder
    Set objInboxFolder = Application.Session.PickFolder
    If Not objInboxFolder Is Nothing Then
        If objInboxFolder.DefaultItemType = olMailItem Then
            Dim strFilter As String
            Dim colItems As Outlook.Items
            Set colItems = objInboxFolder.Items
            If colItems.Count > 0 Then
                Dim i As Long
                Dim objXlApp As Excel.Application
                Dim objXlSh As Excel.Worksheet
                Dim objDic As Scripting.Dictionary
                Set objDic = New Scripting.Dictionary
                Dim strSubstring As String
                For i = 1 To colItems.Count
                    strSubstring = Left(colItems.Item(i).Subject, 10)
                    If InStr(strSubstring, "Fwd:") = 0 And _
                        InStr(strSubstring, "FW:") = 0 And _
                        InStr(strSubstring, "Re:") = 0 And _
                        InStr(strSubstring, "RE:") = 0 And _
                        InStr(strSubstring, "{EXTERNAL}") = 0 Then
                            If objDic.Exists(colItems.Item(i).Subject) Then
                                objDic.Item(colItems.Item(i).Subject) = objDic.Item(colItems.Item(i).Subject) + 1
                            Else: objDic.Add colItems.Item(i).Subject, 1
                            End If
                    End If
                Next
                Set objXlApp = New Excel.Application
                objXlApp.Visible = True
                objXlApp.Workbooks.Add
                Set objXlSh = objXlApp.Worksheets.Item("Sheet1")
                objXlApp.ScreenUpdating = False
                objXlSh.Range("A1").Value = "Subject"
                objXlSh.Range("B1").Value = "Count"
                For i = LBound(objDic.Keys) To UBound(objDic.Keys)
                    objXlSh.Range("A1").Offset(i + 1, 0).Value = objDic.Keys(i)
                    objXlSh.Range("B1").Offset(i + 1, 0).Value = objDic.Item(objDic.Keys(i))
                Next
                objXlApp.Range("A:B").Columns.AutoFit
                objXlApp.ScreenUpdating = True
            End If
        End If
    Else: Exit Sub
    End If
End Sub

For example, assume you want to count emails in inbox that do not contain any prefix like "Re:", "RE:", "Fwd:", "FW:", or "{EXTERNAL}, in Subject":
View attachment 87709


Thank you! This definitely counted included all emails without any prefix. However, I was looking to include ALL emails, but ignore prefixes. So if there are 5 emails with the same subject, but for multiple RE: prefixes, it would include those as the same subject. Any suggestions?
 
Upvote 0

Forum statistics

Threads
1,223,879
Messages
6,175,148
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top