Question

第一次发帖 - 希望我很清楚。

我不是excel VBA的经验，但已经设法通过这些论坛找到并更改了（在我的IT领域的帮助下）一些代码，这些代码按照单元格中的日期计算Outlook文件夹中的电子邮件数量。在一个文件夹中计算电子邮件时，代码工作正常。我需要代码做的是计算许多文件夹中的电子邮件（其中列表存储在工作簿的工作表中）并将计数输出到单独的列中。（希望发布一张图片作为例子，但我需要更高的代表！）

这是我到目前为止的代码：

Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer, DateCount As Integer, iCount As Integer
Dim myDate As Date
Dim myCell As Object

Dim dictEmailDates As New Scripting.Dictionary

Dim folder1 As String, folder2 As String, folder3 As String
folder1 = Sheets("Sheet1").Cells.Cells(2, 5)
folder2 = Sheets("Sheet1").Cells.Cells(2, 6)
folder3 = Sheets("Sheet1").Cells.Cells(2, 7)

' Get Outlook Object
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

' Get Folder Object
On Error Resume Next
Set objFolder = objnSpace.Folders(folder1)

If Not IsEmpty(folder2) Then
    Set objFolder = objFolder.Folders(folder2)
End If
If Not IsEmpty(folder3) Then
    Set objFolder = objFolder.Folders(folder3)
End If

If Err.Number <> 0 Then
    Err.Clear
    MsgBox "Folder doesn't exist. Please ensure you have input the correct folder details."
    Set objFolder = Nothing
    Set objnSpace = Nothing
    Set objOutlook = Nothing
    Exit Sub
End If

EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count

' Put ReceivedTimes in array
CountEmails objFolder, dictEmailDates

' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

' Count the emails dates equal to active cell
Sheets("Sheet1").Range("A2").Select
Do Until IsEmpty(ActiveCell)

    DateCount = 0
    myDate = ActiveCell.Value

    If dictEmailDates.Exists(myDate) Then
        DateCount = dictEmailDates(myDate)
    End If

    Selection.Offset(0, 1).Activate
    ActiveCell.Value = DateCount
    Selection.Offset(1, -1).Activate
Loop
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub

Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count

' Put ReceivedTimes in array
EmailCount = objFolder.Items.Count
For iCount = 1 To EmailCount
    With objFolder.Items(iCount)
        dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
        If dictEmailDates.Exists(dateKey) Then
            dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
        Else
            dictEmailDates.Add dateKey, 1
        End If
    End With
Next iCount

For iCount = 1 To FolderCount
    CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub

希望有人能帮忙吗？如果有什么额外的或者如果我需要更多地解释自己，请告诉我！

干杯，阿德里安

Answer 1

如果我关注，问题是folder1（或2或3）是唯一被计算的文件夹。问题似乎是您只将一个文件夹加载到字典中（基于我认为它是folder3的代码）。我将通过如下重构代码来解决这个问题（我还添加了一些性能改进并删除了一堆看起来什么也没做的东西）：

Sub CountingEmails()
' Set Variables
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim myDate As Date
Dim dictEmailDates As New Scripting.Dictionary
Dim i As Integer
Dim dcell As Range 'refering to range saves you having to keep retyping range to use,
'reducing likelihood of typo
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'refering to ws saves having to type out
'Sheet1 each time, and also makes it easier to update code if sheet name ever changes

'Turn off screen updates for faster run
Application.ScreenUpdating = False

'Get the Outlook items setup
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

'Start looping through the folders
i = 0
Do Until IsEmpty(ws.Cells.Cells(2, 5 + i))
    ' Get Folder Object
    On Error Resume Next
    Set objFolder = objnSpace.Folders(ws.Cells.Cells(2, 5 + i))

    'Get count of items and put in array based on ReceivedTimes
    CountEmails objFolder, dictEmailDates
Loop

'Notice I completely removed Date and Folder count from this sub, they were only ever
'set here, not used. Looked like legacy code from attempting to perform the count in
'this sub rather than the self-referencing sub you created.

' Clear Outlook objects
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

' Count the emails dates equal to current cell
i = 2
Set dcell = ws.Range("A" & i)
Do Until IsEmpty(dcell)

    DateCount = 0
    myDate = dcell.Value

    If dictEmailDates.Exists(myDate) Then
        DateCount = dictEmailDates(myDate)
    End If

    dcell.Offset(0, 1).Value = DateCount
    i = i + 1
    Set dcell = ws.Range("A" & i)
Loop

Application.ScreenUpdating = True
MsgBox "Count Complete", vbInformation, "Count of Emails."
End Sub

Sub CountEmails(objFolder, dictEmailDates)
EmailCount = objFolder.Items.Count
FolderCount = objFolder.Folders.Count

' Put ReceivedTimes in array
For iCount = 1 To EmailCount
    With objFolder.Items(iCount)
        dateKey = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime))
        If dictEmailDates.Exists(dateKey) Then
            dictEmailDates(dateKey) = dictEmailDates(dateKey) + 1
        Else
            dictEmailDates.Add dateKey, 1
        End If
    End With
Next iCount

For iCount = 1 To FolderCount
    CountEmails objFolder.Folders(iCount), dictEmailDates
Next iCount
End Sub

使用excel VBA计算电子邮件

1 个答案: