Отправить данные категории почты в Excel с помощью Outlook VBA

Question

Я считаю количество писем в Outlook по категориям.

Я получаю вывод в MsgBox.

Я хочу вывод в Excel.

Пример-

Категория Номер электронных писем
Материал (синий) 42
Поставщик (зеленый) 5

Макрос используется какниже

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

Исходя из вашего кода, я обновил свой код, вы можете вставить все и запустить его:

 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

Вы можете изменить поле fileUrl, fileName, Excel в качестве реальной ситуации.