Подсчитайте все электронные письма Outlook от каждого отправителя, затем отобразите по годам и месяцам в Excel - PullRequest
Новая
       34

Подсчитайте все электронные письма Outlook от каждого отправителя, затем отобразите по годам и месяцам в Excel

0 голосов
/ 27 февраля 2020

Есть ли способ, которым я мог бы (в Excel) подсчитать все электронные письма Outlook от каждого отправителя, а затем отобразить по году и месяцу в Excel?

Я пытался отредактировать приведенный ниже код, но я не уверен если я на правильном пути.

В настоящее время я использую Excel 2010 и Outlook 2010, если это поможет. 

Sub EmailCount()
Dim objOutlook As Object
Dim objnSpace As Object
Dim objFolder As MAPIFolder
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Dim NextRow As Long
Dim FirstRow As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

On Error Resume Next
'Set objFolder = objnSpace.Folders("Personal Folders").Folders("Inbox")
Set objFolder = objnSpace.Folders("Inbox")
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If

Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.Sort "[SentOn]", True
myItems.SetColumns "[SentOn]"

FirstRow = 2
ActiveSheet.Rows(FirstRow & ":" & ActiveSheet.Rows.Count).Clear
ActiveSheet.UsedRange.Borders.LineStyle = xlNone

For Each myItem In myItems
    dateStr = GetDate(myItem.SentOn)
    If Not dict.Exists(dateStr) Then
        dict(dateStr) = 0
    End If
    dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem

' Output dates that have emails
For Each o In dict.Keys
    NextRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
    msg = o
    ActiveSheet.Range("A" & NextRow) = msg
Next
' Output email count per day:
For Each o In dict.Keys
    NextRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row + 1
    msg = dict(o)
    ActiveSheet.Range("B" & NextRow) = msg
Next
With ActiveSheet.Range("A1").CurrentRegion
    .HorizontalAlignment = xlCenter
    .Borders.LineStyle = xlContinuous
    .Borders.Weight = xlThin
    .Borders.ColorIndex = xlAutomatic
End With

ActiveSheet.Columns.AutoFit
End Sub


Function GetDate(dt As Date) As String
GetDate = CDate(Day(dt) & "-" & Month(dt) & "-" & Year(dt))
End Function
...