Option Explicit 
 '##############################################
 '
 '          Excel Code
 '
 '##############################################
 
Sub xlWordsAndChars() 
     '
     '****************************************************************************************
     '       Function:   calculates word count and char count for xl selection
     '       Passed Values:  None
     '****************************************************************************************
     '
     '
    Dim N           As Long 
    Dim NLines      As Long 
    Dim NumChars    As Integer 
    Dim NumChars2   As Integer 
    Dim NumWords    As Integer 
    Dim strBuffer   As String 
    Dim strText     As String 
    Dim xlCell      As Range 
     
     
    N = 0 
    NLines = 0 
    For Each xlCell In Selection 
        N = N + 1 
        strText = xlCell.Text 
        Call WordsAndChars(strText, NumWords, NumChars, NumChars2, False) 
        If NumChars = 0 Then 
            strBuffer = strBuffer & "cell # " & N & "    is blank" & vbCrLf 
            NLines = NLines + 1 
        Else 
            strBuffer = strBuffer & "cell # " & N & vbCrLf & _ 
            vbTab & "# words = " & NumWords & vbCrLf & _ 
            vbTab & "# characters = " & NumChars & vbCrLf & _ 
            vbTab & "# non-blank characters = " & NumChars2 & vbCrLf 
            NLines = NLines + 4 
        End If 
        If NLines >= 40 Then 
            MsgBox strBuffer, vbInformation & vbOKOnly, "Count of words & chars" 
            NLines = 0 
            strBuffer = "" 
        End If 
    Next xlCell 
     
    MsgBox strBuffer, vbInformation & vbOKOnly, "Count of words & chars" 
     
End Sub 
 
 '##############################################
 '
 '          Word Code
 '
 '##############################################
 
Sub wrdWordsAndChars() 
     '
     '****************************************************************************************
     '       Function    counts individual words and characters in the current selection
     '       Passed Values:  none
     '****************************************************************************************
     '
     '
    Dim NumChars    As Integer 
    Dim NumChars2   As Integer 
    Dim NumWords    As Integer 
    Dim strText     As String 
     '
     '           move selection text into string variable
     '
    strText = Selection.Text 
     '
     '           call word and char function with display = true
     '
    Call WordsAndChars(strText, NumWords, NumChars, NumChars2, True) 
     
End Sub 
 
 '##############################################
 '
 '          Common Code
 '
 '##############################################
 
Sub WordsAndChars(strText As String, NumWords As Integer, NumChars, NumChars2, _ 
    Optional DisplayResults As Boolean = True) 
     '
     '****************************************************************************************
     '       Function    counts individual words and characters in a text string (strBuffer)
     '       Limitations:    leading and trailing blanks are ignored for word counting but
     '                           are included in character counting
     '                       words are assumed to be separated by a single space.  When
     '                           separated by more than one space, the extra space is ignored
     '                           for word counting, but is included for character counting
     '       Passed Values:
     '           strText    [in, string]  text string to be parsed
     '           NumWords   [out, integer] # of words found
     '           NumChars   [out, integer] # of characters found
     '           NumChars2  [out, integer] # of characters found (excluding blanks)
     '           DisplayResults [in, boolean, OPTIONAL] boolean flag to indicate if results
     '               are to be displayed via MsgBox
     '
     '****************************************************************************************
     '
     '
    Dim Words() As String 
     
    Call ParseText(RemoveExtra(Trim(strText), " ", 1), " ", NumWords, Words, False) 
    NumChars = Len(strText) 
    NumChars2 = Len(Replace(strText, " ", "")) 
    If DisplayResults = True Then 
        MsgBox "Count of words and characters for selection:" & vbCrLf & _ 
        "  # words = " & NumWords & vbCrLf & _ 
        "  # characters = " & NumChars & vbCrLf & _ 
        "  # non-blank characters = " & NumChars2, vbInformation & vbOKOnly 
    End If 
     
End Sub 
 
Sub ParseText(strBuffer As String, Delim As String, NW As Integer, Words, _ 
    Optional FetchWords As Boolean = True) 
     '
     '****************************************************************************************
     '       Function    parses individual words from a text string (strBuffer) and returns
     '                   # words found (NW) and (optionally) a string array of individual
     '                   words (Words)
     '       Limitations:  parses based on a single delimiter (Delim)
     '                     Words must be dimensioned by the calling procedure to accomodate
     '                     expected # of words
     '                     If in doubt, call ParseText first with FetchWords = False to
     '                       (just) count # of words first; the ReDim Words at NW and call
     '                       ParseText a 2nd time with FetchWords = True
     '       Passed Values:
     '           strBuffer  [in, string]  text string to be parsed
     '           Delim      [in, string]  delimiter to be used for parsing
     '           NW         [out, integer] # of words found
     '           Words      [out, string array] array of words found
     '           FetchWords [in, string, OPTIONAL] boolean flag to indicate if ParseText is
     '               to fetch both NW and Words or just NW
     '       HISTORY
     '   30Apr'05    MWE added FetchWords arguement
     '
     '****************************************************************************************
     '
     '
    Dim Item        As Variant 
    Dim strItems()  As String 
    Dim strTemp     As String 
     
     '
     '           load text string into temp string
     '
    strTemp = strBuffer 
     '
     '           parse with Delim
     '
    strItems = Split(strTemp, Delim) 
     '
     '           determine NW and load Words array for return
     '
    NW = 0 
    For Each Item In strItems 
        NW = NW + 1 
        If FetchWords = True Then 
            Words(NW) = Item 
        End If 
    Next 
     
End Sub 
 
Function RemoveExtra(strText As String, _ 
    Optional Char As String = " ", _ 
    Optional Num As Long = 1) As String 
     '
     '****************************************************************************************
     '       Function    removes extra repeated characters from a target string.  The revised
     '                   string is returned as the functional value.
     '       Passed Values:
     '           strText  [in, string]  target string to be examined
     '           Char     [in, string, OPTIONAL]  target character {default = " "}
     '           Num      [in, long, OPTIONAL] number of allowable repetitions {default = 1}
     '
     '   NOTES:  let strOld = "now is the  time for all good men to come to the aid of their party"
     '
     '           note the two blank between "the" and "time"
     '
     '           we set strNew = RemoveExtra(strOld, " ", 1) then
     '           strNew is now = "now is the time for all good men to come to the aid of their party"
     '****************************************************************************************
     
     '
     '
    Dim OrigLen As Long 
     '
     '           ensure acceptable value for Num
     '
    If Num < 0 Then 
        MsgBox "RemoveExtra: value for Num is not valid", "vbCritical + vbOKOnly" 
        Exit Function 
    End If 
     '
     '           copy original text string into RemoveExtra
     '           keep calling Replace with repeated (target) char string of length Num+1
     '               replaced by similar string of length Num until result does not change
     '
    RemoveExtra = strText 
    Do Until Len(RemoveExtra) = OrigLen 
        OrigLen = Len(RemoveExtra) 
        RemoveExtra = Replace(RemoveExtra, String(Num + 1, Char), String(Num, Char)) 
    Loop 
     
End Function