用excel計算電子郵件VBA

Question

第一次發佈 - 希望我已經清楚了。

我沒有用excel VBA查看過，但已經設法通過這些論壇查找和更改（在我的IT區域的幫助下）一些代碼，這些代碼根據單元格中的日期統計Outlook文件夾中的電子郵件數量。在一個文件夾中計算電子郵件時，代碼工作正常。我需要的代碼是將多個文件夾中的電子郵件（其中的列表存儲在工作簿的工作表中）計數並將計數輸出到單獨的列中。 （！希望能發佈圖片作爲一個例子，但我需要更高的REP）

這裏是我的代碼至今：

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