Option Explicit
Sub test()
Dim oDict As Scripting.Dictionary
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Dim arrData() As Variant
Dim CategoryCnt As Integer
Dim c As Long

Set oDict = New Scripting.Dictionary

Set olApp = New Outlook.Application

Set olNS = olApp.GetNamespace("MAPI")

Set olFolder = olNS.GetDefaultFolder(olFolderInbox)

CategoryCnt = olNS.Categories.Count

ReDim arrData(1 To 2, 1 To CategoryCnt)

c = 0
For Each olItem In olFolder.Items
If Not oDict.Exists(olItem.Categories) Then
c = c + 1
arrData(1, c) = olItem.Categories
arrData(2, c) = 1
oDict.Add olItem.Categories, c
Else
arrData(2, oDict.Item(olItem.Categories)) = arrData(2, oDict.Item(olItem.Categories)) + 1
End If
Next olItem

ReDim Preserve arrData(1 To 2, 1 To c)

Range("A2").Resize(UBound(arrData, 2), UBound(arrData, 1)).Value = Application.Transpose(arrData)

End Sub