Outlook для сопоставления количества писем, полученных в определенные дни

Question

У меня есть код, который должен идти в папку Outlook, и подсчитывать, сколько писем было отправлено на каждую дату на этой неделе.

, но на данный момент он просто не читает его правильно!

Последние недели данные и что код тянет следующим образом:

monday: 21 in folder - counts 10 
tuesday: 10 - 7 
wednesday: 10 -13 
thursday: 9 - 11 
friday: 2 - 1 

вот код:

' 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 arrEmailDates() 

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

' Get Folder Object 
On Error Resume Next 
Set objFolder = objnSpace.Folders("Estates").Folders("Bookings") 
If Err.Number <> 0 Then 
    Err.Clear 
    MsgBox "No such folder." 
    Set objFolder = Nothing 
    Set objnSpace = Nothing 
    Set objOutlook = Nothing 
    Exit Sub 
End If 

' Put ReceivedTimes in array 
EmailCount = objFolder.Items.Count 
For iCount = 1 To EmailCount 
    With objFolder.Items(iCount) 
     ReDim Preserve arrEmailDates(iCount - 1) 
     arrEmailDates(iCount - 1) = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) 
    End With 
Next iCount 

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

' Count the emails dates equal to active cell 
Sheets("test email count").Range("e2").Select 
Do Until IsEmpty(ActiveCell) 

    DateCount = 0 
    myDate = ActiveCell.Value 

    For i = 0 To UBound(arrEmailDates) - 1 
     If arrEmailDates(i) = myDate Then DateCount = DateCount + 1 
    Next i 

    Selection.Offset(0, 1).Activate 
    ActiveCell.Value = DateCount 
    Selection.Offset(1, -1).Activate 
Loop 

бы кто-нибудь сможет сказать мне, где я буду неправильно?

Answer 1

У меня был этот код, сидящий в течение нескольких лет - возможно, он нуждается в настройке.
Вам нужно будет создать книгу и дать лист кодовому имени shtAnalysis.

Добавьте этот код в нормальный модуль в книгу и выполните процедуру CreateReport.

Public Sub CreateReport() 

    Dim oOutlook As Object 'Outlook.Application 
    Dim nNameSpace As Object 'Outlook.Namespace 
    Dim mFolderSelected As Object 'Outlook.MAPIFolder 
    Dim oItem As Object 
    Dim rLastCell As Range 
    Dim x As Long 

    'Solves the "Code execution has been interrupted" problem. 
    Application.EnableCancelKey = xlDisabled 
    Application.EnableCancelKey = xlInterrupt 

    Set oOutlook = GetObject(, "Outlook.Application") 
    Set nNameSpace = oOutlook.GetNamespace("MAPI") 

    Set mFolderSelected = nNameSpace.PickFolder 

    shtAnalysis.Cells.Delete Shift:=xlUp 

    ProcessFolder mFolderSelected 

    Set rLastCell = LastCell(shtAnalysis) 

    With shtAnalysis 
     .Columns.ColumnWidth = 100 
     .Cells.EntireColumn.AutoFit 

     .Range(.Cells(1, 1), .Cells(rLastCell.Row, rLastCell.Column)).Sort _ 
      Key1:=.Range("A2"), Order1:=xlDescending, Header:=xlYes 

     'Add totals to row 1 & column A. 
      .Rows("1:1").Insert Shift:=xlDown 
      .Columns("A:A").Insert Shift:=xlToRight 
      For x = 3 To rLastCell.Column 
       With .Cells(1, x) 
        .FormulaR1C1 = "=SUM(R3C:R" & rLastCell.Row & "C)" 
        .NumberFormat = "General" 
        .Font.Bold = True 
        .Font.ColorIndex = 3 
       End With 
      Next x 
      For x = 3 To rLastCell.Row 
       With .Cells(x, 1) 
        .FormulaR1C1 = "=SUM(RC3:RC" & rLastCell.Column & ")" 
        .NumberFormat = "General" 
        .Font.Bold = True 
        .Font.ColorIndex = 3 
       End With 
      Next x 
      'Add grand total. 
      With .Cells(1, 1) 
       .FormulaR1C1 = "=SUM(RC3:RC" & rLastCell.Column & ")" 
       .NumberFormat = "General" 
       .Font.Bold = True 
       .Font.Size = 14 
       .Font.ColorIndex = 3 
      End With 
    End With 

    ThisWorkbook.Activate 
    MsgBox "Complete", vbOKOnly 

End Sub 

Private Sub ProcessFolder(oParent As Object) 

    Dim oFolder As Object 'Outlook.MAPIFolder 
    Dim oMail As Object 
    Dim sName As String 

    On Error Resume Next 
    For Each oMail In oParent.Items 
     PlaceDetails Int(oMail.SentOn), oParent 
    Next oMail 

    If (oParent.Folders.Count > 0) Then 
     For Each oFolder In oParent.Folders 
      ProcessFolder oFolder 
     Next oFolder 
    End If 
    On Error GoTo 0 

End Sub 

Public Sub PlaceDetails(dDate As Date, oFolders As Object) 

    Dim rFoundCell As Range 
    Dim lRow As Long, lColumn As Long 
    Dim sItem As String 
    Dim lLevel As Long 
    Dim x As Long 

    sItem = oFolders.FullFolderPath 'User the full path of the folder. 
    If Left(sItem, "2") = "\\" Then 
     sItem = Mid(sItem, 3, Len(sItem)) 'Remove leading backslashes. 
    End If 
    lLevel = Len(sItem) - Len(Replace(sItem, "\", "")) 

    For x = 1 To lLevel 
     sItem = Left(sItem, InStr(sItem, "\") - 1) & Replace(sItem, "\", Chr(10) & Application.WorksheetFunction.Rept(" ", x) & Chr(149), InStr(sItem, "\"), 1) 
    Next x 


    With shtAnalysis 
     .Columns(1).EntireColumn.AutoFit 

     'First find the column by looking for sItem in row 1. 
     Set rFoundCell = .Rows("1:1").Cells.Find(What:=sItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext) 
     If Not rFoundCell Is Nothing Then 
      lColumn = rFoundCell.Column 
     Else 
      lColumn = LastCell(shtAnalysis).Column + 1 
     End If 
     Set rFoundCell = Nothing 

     'Next find the row by looking for dDate in column A. 
     Set rFoundCell = .Columns("A:A").Cells.Find(What:=dDate, After:=.Cells(2, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext) 
     If Not rFoundCell Is Nothing Then 
      lRow = rFoundCell.Row 
     Else 
      lRow = LastCell(shtAnalysis).Row + 1 
     End If 
     Set rFoundCell = Nothing 

     'Place the data. 
     .Cells(lRow, 1).Value = dDate 
     .Cells(1, lColumn).Value = sItem 
     If .Cells(lRow, lColumn) = "" Then 
      .Cells(lRow, lColumn).NumberFormat = "General" 
      .Cells(lRow, lColumn) = 1 
     Else 
      .Cells(lRow, lColumn) = .Cells(lRow, lColumn) + 1 
     End If 

    End With 

End Sub 

' Purpose : Finds the last cell containing data or a formula within the given worksheet. 
'    If the Optional Col is passed it finds the last row for a specific column. 
'--------------------------------------------------------------------------------------- 
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range 

    Dim lLastCol As Long, lLastRow As Long 

    On Error Resume Next 

    With wrkSht 
     If Col = 0 Then 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     Else 
      lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
      lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row 
     End If 

     If lLastCol = 0 Then lLastCol = 1 
     If lLastRow = 0 Then lLastRow = 1 

     Set LastCell = wrkSht.Cells(lLastRow, lLastCol) 
    End With 
    On Error GoTo 0 

End Function 

Это даст результат, как:

Answer 2

Чем больше ошибка:

On Error Resume Next 
' without 
On Error GoTo 0 
' to stop bypassing errors. 

Фактическая ошибка, скорее всего:

For i = 0 To UBound(arrEmailDates) - 1 

Код может выглядеть например:

Sub countMail() 

    ' 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 arrEmailDates() 

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

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

    If Err.Number <> 0 Then 
     Err.Clear 
     MsgBox "No such folder." 
     Set objFolder = Nothing 
     Set objnSpace = Nothing 
     Set objOutlook = Nothing 
     Exit Sub 
    End If 

    On Error GoTo 0  ' Turn off error bypass as quickly as possible 

    ' Put ReceivedTimes in array 
    EmailCount = objFolder.items.Count 

    For iCount = 1 To EmailCount 

     With objFolder.items(iCount) 

      ReDim Preserve arrEmailDates(iCount - 1) 

      ' Bypass error on items without a received date 
      On Error Resume Next 
      arrEmailDates(iCount - 1) = DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) 
      On Error GoTo 0  ' Turn off error bypass as quickly as possible 

     End With 

    Next iCount 

    'For i = 0 To UBound(arrEmailDates) - 1 
    For i = 0 To UBound(arrEmailDates) 
     Debug.Print i & " - " & arrEmailDates(i) 
    Next i 

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

    ' Count the emails dates equal to active cell 
    Sheets("test email count").Range("e2").Select 
    Do Until IsEmpty(ActiveCell) 

     DateCount = 0 
     myDate = ActiveCell.Value 
     Debug.Print " mydate: " & myDate 

     'For i = 0 To UBound(arrEmailDates) - 1 
     For i = 0 To UBound(arrEmailDates) 
      If arrEmailDates(i) = myDate Then DateCount = DateCount + 1 
     Next i 

     Selection.Offset(0, 1).Activate 
     ActiveCell.Value = DateCount 
     Selection.Offset(1, -1).Activate 

    Loop 

End Sub