Code Counts Emails But Sometimes Adds 1 Additional Email On To Days

[Si1209]

So someone, who has left my work, created this code to count emails in specified mailboxes:-


Sub NWHFX2()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

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

' Today - 3 Count in NW HFX''''''''''''''''''

Dim iCount As Integer, DateCount As Integer
Dim myDate As Date
EmailCount = objFolder.Items.Count
DateCount = 0
myDate = Sheets("Sheet1").Range("f9").Value

For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
End With
Next iCount

Cells(10, 6).Value = DateCount

' Today - 4 Count in NW HFX'''''''''''''''''

DateCount = 0
myDate = Sheets("Sheet1").Range("e9").Value

For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
End With
Next iCount

Cells(10, 5).Value = DateCount

' Today - 5 Count NW HFX'''''''''''''''''

DateCount = 0
myDate = Sheets("Sheet1").Range("d9").Value

For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
End With
Next iCount

Cells(10, 4).Value = DateCount

End Sub
Sub NWHFX3()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")

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

' Today - 6 Count in NW HFX''''''''''''''''''

Dim iCount As Integer, DateCount As Integer
Dim myDate As Date
EmailCount = objFolder.Items.Count
DateCount = 0
myDate = Sheets("Sheet1").Range("c9").Value

For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
End With
Next iCount

Cells(10, 3).Value = DateCount

End Sub

Most of the time the code runs fine and works and pulls through the correct information, however sometimes, like today when you run the macro and it imports data in to the Excel table it decides to put 1 email in for the data in cell 10,3. However, when this is checked no emails in the inbox are dated for that day, the date referrenced in cell 10,3 being 5 days prior to today so the dates & days will change on a daily basis.

Is this an issue with the code or is it something within Outlook that you know of that may be causing this issue?

[skatonni]

Possibly you need an


If EmailCount > 0 then

For iCount = 1 To EmailCount

[Si1209]

Fantastic thanks for that, I will run it for a week or so to make sure it stops the error and report back, as I say it doesnt always do it every day so want to just make sure over a period of time it stops the incorrect figures coming through

[Si1209]

So it finally happened on the actual sheet, the macro counted emails that werent there for that date and added emails on for days that had 1 email in. I ran the template where i had the above wrote in to the code but this still returned the same information with the additional information. Back to the drawing board with this so if anyone else has any suggestions please get in touch.

[skatonni]

"On Error Resume Next" has to be turned off when it has served its purpose otherwise errors that should not be ignored are ignored.

In this part of the code an error indicates the folder does not exist. The On Error GoTo 0 was missing.


On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - $north west halifax").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
On Error GoTo 0



I assume there can be items that do not have a received time property in the folder. If so there will be an error that would be ignored.


If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If


But the DateCount part is not in error so that item is counted.

Try adding the On Error GoTo 0 and see.

If this is the problem, you could validate the item.


If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

[Si1209]

Sub NWHFX1()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNameSpace("MAPI")
Application.ScreenUpdating = False

On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - $north west halifax").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
''MsgBox "No such folder."
Exit Sub
End If
On Error GoTo 0

Dim iCount As Integer, DateCount As Integer
Dim myDate As Date
EmailCount = objFolder.Items.Count
DateCount = 0
myDate = Sheets("Sheet1").Range("h9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

Cells(10, 8).Value = DateCount
'MsgBox "Number of emails in MIS folder with matching date: " & DateCount, , "MIS date count"
'On Error Resume Next
' Set objFolder = objnSpace.Folders("Mailbox - $north west halifax").Folders("Inbox")
''If Err.Number <> 0 Then
'Err.Clear
'''MsgBox "No such folder."
'Exit Sub
'End If

DateCount = 0
myDate = Sheets("Sheet1").Range("g9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing

Cells(10, 7).Value = DateCount



End Sub
Sub NWHFX2()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNameSpace("MAPI")

On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - $north west halifax").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
''MsgBox "No such folder."
Exit Sub
End If
On Error GoTo 0

' Today - 3 Count in NW HFX''''''''''''''''''

Dim iCount As Integer, DateCount As Integer
Dim myDate As Date
EmailCount = objFolder.Items.Count
DateCount = 0
myDate = Sheets("Sheet1").Range("f9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

Cells(10, 6).Value = DateCount

' Today - 4 Count in NW HFX'''''''''''''''''

DateCount = 0
myDate = Sheets("Sheet1").Range("e9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then DateCount = DateCount + 1
End With
Next iCount
End If

Cells(10, 5).Value = DateCount

' Today - 5 Count NW HFX'''''''''''''''''

DateCount = 0
myDate = Sheets("Sheet1").Range("d9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

Cells(10, 4).Value = DateCount




End Sub

Sub NWHFX3()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNameSpace("MAPI")

On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - $north west halifax").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
''MsgBox "No such folder."
Exit Sub
End If
On Error GoTo 0

' Today - 6 Count in NW HFX''''''''''''''''''

Dim iCount As Integer, DateCount As Integer
Dim myDate As Date
EmailCount = objFolder.Items.Count
DateCount = 0
myDate = Sheets("Sheet1").Range("c9").Value

If EmailCount > 0 Then
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
If .Class = olMail Then
' Items may not be mailitems
' If those items do not have a ReceivedTime property
' they will still be counted
' due to the On Error Resume Next
If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) = myDate Then
DateCount = DateCount + 1
End If
Else
Debug.Print .Subject

End If
End With
Next iCount
End If

Cells(10, 3).Value = DateCount

End Sub

So i've done that but now all it returns in the spreadsheet is 0 :( Im not very good with VBA so apologies for the questions and if its something really simple.

[skatonni]

You can try debugging to see the problem as it occurs rather than waiting for the final result. http://www.cpearson.com/excel/DebuggingVBA.aspx