Send mail category data to Excel using Outlook VBA - excel

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.