How Do You Count Text Occurrences in Excel AND Export to the Body of an Outlook Email?

2. In my report, there is one column that may have any word in it. I would like to identify all WORDS that occur in 15 or more cells in that column. So in my email, if the words 'apple', banana' and 'orange' occur 15, 17 and 12 times respectively, I would like to be able to export that to the body of my email in this manner (no need for oranges as it occurs less than 15):

Will this word list be sorted? Unless you would be starting with a specific word list to work with, it would be easier to count words if they were sorted. Then you could just go through the rows and increment the count until the word changes.

This seems to work. I already had the SendMAPIMessage subroutine in place in an app of my own, so I just had to write the BuildMessage part.

In the VBA window, you'll need to go to Tools - References and select the reference to Microsoft Outlook xx.0 Object Library to make it work. They're in alpha order.

Good luck!

Option Explicit
Dim Rw As Long, Col As Long, Cnt1 As Long, Cnt2 As Long
Dim Recipient As String, CCRecipient As String, BodyTxt As String
Dim NewLine As String
Const AddressExt = "@yourcompany.com"

Sub BuildMessage()
    NewLine = Chr(10)
    Recipient = "thisone; thatone" ' This could be built from your spreadsheet as well
    CCRecipient = "someoneelse"
    BodyTxt = "Good morning all, today we had " & Range("A1").Value & " new donors to our charity."
    BodyTxt = BodyTxt & NewLine & NewLine ' Double-space

    Rw = 1
    Col = 4  ' Word column
    Cnt1 = 0

    ' This will only work if the words are sorted
    Do Until Cells(Rw, Col).Value = ""
        If Cells(Rw, Col).Value = Cells(Rw + 1, Col).Value Then
            Cnt1 = Cnt1 + 1
        Else
            If Cnt1 > 14 Then
                BodyTxt = BodyTxt & Cnt1 & " " & Cells(Rw, Col).Value & " donated to the charity."
                BodyTxt = BodyTxt & NewLine
            End If
            Cnt1 = 0
        End If
        Rw = Rw + 1
    Loop

    Rw = 1
    Col = 6 ' Yes/No column
    Cnt1 = 0
    Cnt2 = 0

    Do Until Cells(Rw, Col).Value = ""
        If UCase(Cells(Rw, Col).Value) = "YES" Then
            Cnt1 = Cnt1 + 1
        ElseIf UCase(Cells(Rw, Col).Value) = "NO" Then
            Cnt2 = Cnt2 + 1
        End If
        Rw = Rw + 1
    Loop
    BodyTxt = BodyTxt & NewLine
    BodyTxt = BodyTxt & Cnt1 & " said they would attend the benefit dinner." & NewLine
    BodyTxt = BodyTxt & Cnt2 & " said they would not attend the benefit dinner." & NewLine & NewLine
    BodyTxt = BodyTxt & "Keep up the good work!"

    Call SendMAPIMessage(Recipient, CCRecipient, BodyTxt, "Charity Update")
End Sub

Sub SendMAPIMessage(MsgTo As String, MsgCC As String, MsgTxt As String, MsgSubject As String)
    Dim TempArray() As String, varArrayItem As Variant, strEmailAddress As String
    Dim objOL As Outlook.Application
    Dim MAPISession As Outlook.Namespace, MAPIFolder As Outlook.MAPIFolder, MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient
        
    Set objOL = New Outlook.Application
    Set MAPISession = objOL.Application.Session
    If Not MAPISession Is Nothing Then
        MAPISession.Logon , , True, False
        Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
        If Not MAPIFolder Is Nothing Then
            Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
            If Not MAPIMailItem Is Nothing Then
                With MAPIMailItem
                    TempArray = Split(MsgTo, ";")
                    For Each varArrayItem In TempArray
                        strEmailAddress = Trim(varArrayItem)
                        If Len(strEmailAddress) > 0 Then
                            Set oRecipient = .Recipients.Add(strEmailAddress & AddressExt)
                            oRecipient.Type = olTo
                            Set oRecipient = Nothing
                        End If
                    Next varArrayItem
                    
                    TempArray = Split(MsgCC, ";")
                    For Each varArrayItem In TempArray
                        strEmailAddress = Trim(varArrayItem)
                        If Len(strEmailAddress) > 0 Then
                            Set oRecipient = .Recipients.Add(strEmailAddress & AddressExt)
                            oRecipient.Type = olCC
                            Set oRecipient = Nothing
                        End If
                    Next varArrayItem
                   
                   .Subject = MsgSubject
                 
                    If StrComp(Left(MsgTxt, 1), "<", vbTextCompare) = 0 Then
                        .HTMLBody = MsgTxt
                    Else
                        .Body = MsgTxt
                    End If
                    On Error GoTo SendErr
                    .Send
                    On Error GoTo 0
                    Set MAPIMailItem = Nothing
                End With
           End If
           Set MAPIFolder = Nothing
        End If
        MAPISession.Logoff
    End If
    Exit Sub

SendErr:
    MsgBox "Unable to send message to " & MsgTo & " " & MsgCC & vbCrLf & vbCrLf & Err.Description
End Sub

I could pre-sort the list. But what do you mean by "go through the rows and increment the count..."

I made that assumption with the code I provided. The loop does what I was referring to (rw = rw + 1).

From an Excel workbook, open the VBA window by pressing Alt+F11. To create a new code module, select Insert - Module. It will default to the name, Module1, which is fine. That's where you would paste the code I provided. To run it, click somewhere in the BuildMessage subroutine and click F5, or to run it one line at a time, press F8 to follow the code in Debug mode and observe the results. To see the value of a variable in debug mode, just hover over it. You can press F5 any time. You can also toggle debug stop(s) on/off by clicking in the band to the left of the code. It will put a stop at that point, indicated by a red dot and red highlighted code. When you press F5, it will run until it hits that line. Then you can press F8 or F5 to continue. If your debug stop is within a loop, you can hit F5 repeatedly and it will bump through the loop. You can also use the Immediate pane (View - Immediate, or Ctrl+G) to check or change variable values or object properties. You can terminate the run any time by selecting Run - Reset, or just clicking the Reset button.

Have fun!