Question

我正在尝试编写宏来将日期，类别和电子邮件数量导出到Outlook中的Excel文件。我从网上找到的查询修改的查询是为了获取类别和电子邮件数量，但我无法弄清楚如何添加日期。

Sub CategoriesEmails()

Dim objOL As Outlook.Application
Set objOL = New Outlook.Application

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 oExcelWorkbook As Excel.Workbook
Dim oExcelWorksheet As Excel.Worksheet
Dim ArrayKey As Variant
Dim ArrayItem As Variant
Dim i As Long
Dim nRow As Integer

On Error Resume Next

Set oExcelWorkbook = ActiveWorkbook
Set oExcelWorksheet = oExcelWorkbook.Sheets("Emails")

Set oFolder = Outlook.Application.Session.PickFolder

Set oDict = CreateObject("Scripting.Dictionary")

sStartDate = InputBox("Type the start date (format MM/DD/YYYY)")
sEndDate = InputBox("Type the end date (format MM/DD/YYYY)")

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

ArrayKey = oDict.Keys
ArrayItem = oDict.Items
nRow = oExcelWorksheet.Range("C" & Rows.Count).End(xlUp).Row + 1

'Input the information into the Excel file
For i = LBound(ArrayKey) To UBound(ArrayKey)
    oExcelWorksheet.Cells(nRow, 3) = ArrayKey(i)
    oExcelWorksheet.Cells(nRow, 4) = ArrayItem(i)
    nRow = nRow + 1
Next

'Save the new Excel file
oExcelWorksheet.Columns("A:B").AutoFit
'oExcelWorkbook.Select
Application.Dialogs(xlDialogSaveAs).Show

Set oFolder = Nothing

 End Sub

结果看起来像这样：

Red 3
Yellow 4
Green 6

Answer 1

分别计算每一天。

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Sub CategoriesEmailsByDay()

' Run from Excel
'  in a workbook where there is a sheet named Emails

' Early binding. Set reference to Outlook XX.X Object library.
Dim objOL As Outlook.Application
Dim oFolder As Outlook.Folder
Dim oItems As Outlook.Items
Dim aitem As Object

Dim oDict As Object
Dim ArrayKey As Variant
Dim ArrayItem As Variant
Dim sStr As String

Dim sStartDate As String
Dim sEndDate As String

Dim datePeriod As Date   ' Loop counter
Dim sStartDay As String
Dim sEndDay As String
Dim strFilter As String
Dim oItemsRes As Outlook.Items

Dim oExcelWorkbook As Excel.Workbook
Dim oExcelWorksheet As Excel.Worksheet

Dim i As Long
Dim nRow As Long

Set objOL = New Outlook.Application
Set oFolder = objOL.Session.PickFolder

Set oItems = oFolder.Items
oItems.Sort "[ReceivedTime]", True

Set oDict = CreateObject("Scripting.Dictionary")

' Dates may be impacted by local settings
' Enter as applicable
sStartDate = Date - 30
sEndDate = Date

Set oExcelWorkbook = ActiveWorkbook
Set oExcelWorksheet = oExcelWorkbook.Sheets("Emails")

nRow = oExcelWorksheet.Range("C" & Rows.Count).End(xlUp).Row + 1

' Process each date separately
For datePeriod = sStartDate To sEndDate
    
    ' Must specify time or the date will be off a few hours
    sStartDay = Format(datePeriod, "DDDDD HH:NN")
    Debug.Print sStartDay
    sEndDay = Format(datePeriod + 1, "DDDDD HH:NN")
    Debug.Print sEndDay
        
    strFilter = "[ReceivedTime] >= '" & sStartDay & "' And [ReceivedTime] < '" & sEndDay & "'"
    Debug.Print strFilter
    
    Set oItemsRes = oItems.Restrict(strFilter)
    
    If oItemsRes.Count > 0 Then
            
        For Each aitem In oItemsRes
            sStr = aitem.Categories
            If Not oDict.Exists(sStr) Then
                oDict(sStr) = 0
            End If
            oDict(sStr) = CLng(oDict(sStr)) + 1
        Next aitem
        
        ArrayKey = oDict.Keys
        ArrayItem = oDict.Items
        
        'Input the information into the Excel file
        For i = LBound(ArrayKey) To UBound(ArrayKey)
            oExcelWorksheet.Cells(nRow, 2) = sStartDay
            oExcelWorksheet.Cells(nRow, 3) = ArrayKey(i)
            oExcelWorksheet.Cells(nRow, 4) = ArrayItem(i)
            nRow = nRow + 1
        Next
        
        ' reinitialize dictionary - to restart counts for next day
        oDict.RemoveAll
    End If

Next

oExcelWorksheet.Columns("A:B").AutoFit

End Sub

用于导出Outlook中的日期，类别和电子邮件数量的宏

1 个答案: