Send mail category data to Excel using Outlook VBA

Question

I count the number of emails in Outlook by Category.

I am getting the output in a MsgBox.

I want the output in Excel.

Example-

Category No of Emails
Material(blue) 42
Vendor(green) 5

Macro used as below

Sub CategoriesEmails()

Dim oFolder As MAPIFolder
Dim oDict As Object
Dim sStartDate As String
Dim sEndDate As String
Dim oItems As Outlook.Items
Dim sStr As String
Dim sMsg As String

On Error Resume Next
Set oFolder = Application.ActiveExplorer.CurrentFolder

Set oDict = CreateObject("Scripting.Dictionary")

sStartDate = Date - 365
sEndDate = Date
Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
oItems.SetColumns ("Categories")

For Each aitem In oItems
    sStr = aitem.Categories
    If Not oDict.Exists(sStr) Then
        oDict(sStr) = 0
    End If
    oDict(sStr) = CLng(oDict(sStr)) + 1
Next aitem

sMsg = ""
For Each aKey In oDict.Keys
    sMsg = sMsg & aKey & ":   " & oDict(aKey) & vbCrLf
Next
MsgBox sMsg

Set oFolder = Nothing

End Sub

Answer 1

Based on your code, I've updated my code, you can paste all and run it:

 Sub CategoriesEmails()

    Dim oFolder As MAPIFolder
    Dim oDict As Object
    Dim sStartDate As String
    Dim sEndDate As String
    Dim oItems As Outlook.Items
    Dim sStr As String
    Dim sMsg As String
    Dim strFldr As String
    Dim OutMail As Object
    Dim xlApp As Object

    On Error Resume Next
    Set oFolder = Application.ActiveExplorer.CurrentFolder

    Set oDict = CreateObject("Scripting.Dictionary")

    sStartDate = Date - 365
    sEndDate = Date
    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
    oItems.SetColumns ("Categories")

    For Each aItem In oItems
    sStr = aItem.Categories
    If Not oDict.Exists(sStr) Then
    oDict(sStr) = 0
    End If
    oDict(sStr) = CLng(oDict(sStr)) + 1
    Next aItem

    sMsg = ""
    i = 0

    strFldr = "D:"
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True
    xlApp.Workbooks.Open strFldr & "test.xlsx"
    xlApp.Sheets("Sheet1").Select
    For Each aKey In oDict.Keys
    xlApp.Range("a1").Offset(i, 0).Value = sMsg & aKey
    xlApp.Range("B1").Offset(i, 0).Value = oDict(aKey) & vbCrLf
    i = i + 1
    Next
    xlApp.Save

    Set oFolder = Nothing

     End Sub

You could change the fileUrl, fileName, Excel field as your actual situation.