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
|