Excel VBA - Count keywords in emails by keyword, by sender

Question

Solution:

Option Compare Text

Sub Count_Emails()

Dim oNS As Outlook.Namespace
Dim oTaskFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oFoldToSearch As Object
Dim intCounter As Integer
Dim oWS As Worksheet
Dim dStartDate, dEnddate As Date
Dim CharityBG, CureBG, PartySJ, WooWooSJ As Integer

Set oWS = Sheets("Sheet1")
Set oNS = GetNamespace("MAPI")
Set oTaskFolder = oNS.Folders("bill.gates@microsoft.com")
Set oFoldToSearch = oTaskFolder.Folders("Inbox").Folders("New Folder")
Set oItems = oFoldToSearch.Items

intCounter = 1
dStartDate = oWS.Range("A1").Value
dEnddate = oWS.Range("B1").Value

Do

    With oWS

        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Charity Work*" And oItems(intCounter).SenderName = "Bill Gates" Then
           CharityBG = CharityBG + 1
        End If
        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Curing Malaria*" And oItems(intCounter).SenderName = "Bill Gates" Then
           CureBG = CureBG + 1
        End If

        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*Ghost Party*" And oItems(intCounter).SenderName = "Steve Jobs" Then
           PartySJ = PartySJ + 1
        End If
        If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
           DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
           oItems(intCounter).Subject Like "*WoooOOOooo*" And oItems(intCounter).SenderName = "Steve Jobs" Then
           WooWooSJ = WooWooSJ + 1
        End If

    End With

    intCounter = intCounter + 1

Loop Until intCounter >= oItems.Count + 1

Set oNS = Nothing
Set oTaskFolder = Nothing
Set oAutomation = Nothing
Set oItems = Nothing
oWS.Range("A2").Value = CharityBG
oWS.Range("A3").Value = CureBG
oWS.Range("B2").Value = PartySJ
oWS.Range("B3").Value = WooWooSJ

End Sub

Question:

I have created an excel VBA script that looks at a folder of a mailbox, uses a date range from two excel cells, looks for emails matching a sender, looks for a keyword in subject line, tallies the occurrences and writes it to an excel cell.

The problem occurs with using an email address as one of the criteria. If I am just looking for the keyword, it works without specifying a sender. If I try to do sender and keyword it returns 0. If I try MailItem.SenderEmailAddress instead it returns a value of 10, no matter what. What am I doing wrong?

Option Compare Text

Sub HowManyDatedEmailsv2()
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("\\Email Address 1\\").Folders("Inbox").Folders("Enquiries")
   Set myItems = objFolder.Items.Restrict("[SenderEmailAddress] <> '\\Email Address 2\\'")
   If Err.Number <> 0 Then
   Err.Clear
   MsgBox "No such folder."
   Exit Sub
   End If

Dim iCount, OnlineAT, CallinAT As Integer
Dim myDate1, myDate2 As Date
EmailCount = myItems.Count
OnlineAT = 0
CallinAT = 0
myDate1 = Sheets("Sheet1").Range("C5").Value
myDate2 = Sheets("Sheet1").Range("C6").Value
For iCount = 1 To EmailCount
With objFolder.Items(iCount)
    If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
       DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
       SenderEmailAddress = "\\Email Address 1\\" And .Subject Like "*~Online*" Then
       OnlineAT = OnlineAT + 1
    End If
    If DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) >= myDate1 And _
       DateSerial(Year(.ReceivedTime), Month(.ReceivedTime), Day(.ReceivedTime)) <= myDate2 And _
       SenderEmailAddress = "\\Email Address 1\\" And .Subject Like "*~Callin*" Then
       CallinAT = CallinAT + 1
    End If
    End With
 Next iCount

Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
Sheets("Summary").Range("C12").Value = OnlineAT
Sheets("Summary").Range("C13").Value = CallinAT

End Sub

Answer 1

I cannot see where you are setting 'SenderEmailAddress' but I had a quick go at it using the Outlook reference ( Microsoft Outlook 15.0 Object Library ). Its similar to what you attempting to do and I can get the count as expected

Sub GetEmailDetails(ByVal strFolder)

    Dim oNS As Outlook.Namespace
    Dim oTaskFolder As Outlook.MAPIFolder
    Dim oItems As Outlook.Items
    Dim oFoldToSearch As Object
    Dim intCounter, intX As Integer
    Dim oWS As Worksheet: Set oWS = Worksheets(1)
    Dim dStartDate, dEnddate As Date
    Dim strSenderName As String

    Set oNS = GetNamespace("MAPI")
    Set oTaskFolder = oNS.GetDefaultFolder(olFolderInbox)
    Set oFoldToSearch = oTaskFolder.Folders(strFolder)
    Set oItems = oFoldToSearch.Items

    intCounter = 1
    intX = 2
    dStartDate = oWS.Cells(24, 3).Value
    dEnddate = oWS.Cells(25, 3).Value
    strSenderName = oWS.Cells(26, 3).Value
    Do

        With oWS

            ' If you wanted to check via email address and not the sender name, you can use this code
            'Dim strSenderEmail As String
            'If oItems(intCounter).SenderEmailType = "EX" Then
            '    strSenderEmail = oItems(intCounter).Sender.GetExchangeUser.PrimarySmtpAddress
            'Else
            '    strSenderEmail = oItems(intCounter).SenderEmailAddress
            'End If

            If DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) >= dStartDate And _
               DateSerial(Year(oItems(intCounter).ReceivedTime), Month(oItems(intCounter).ReceivedTime), Day(oItems(intCounter).ReceivedTime)) <= dEnddate And _
               oItems(intCounter).Subject Like "*Training Session*" And oItems(intCounter).SenderName = strSenderName Then

                .Cells(intX, 1).Value = oItems(intCounter).CreationTime
                .Cells(intX, 2).Value = oItems(intCounter).ReceivedTime
                .Cells(intX, 3).Value = oItems(intCounter).Subject
                .Cells(intX, 4).Value = oItems(intCounter).SenderName
                .Cells(intX, 5).Value = oItems(intCounter).SenderEmailAddress
                .Cells(intX, 6).Value = oItems(intCounter).CC
                .Cells(intX, 7).Value = oItems(intCounter).SenderEmailType
                '.Cells(intX, 8).Value = oItems(intCounter).Body

                intX = intX + 1

            End If

        End With

        intCounter = intCounter + 1

    Loop Until intCounter >= oItems.Count + 1

    Set oNS = Nothing
    Set oTaskFolder = Nothing
    Set oAutomation = Nothing
    Set oItems = Nothing

End Sub

I have left some of the items you have access to with this object. Hope this helps