Option Explicit
Sub xlWordsAndChars()
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
Sub wrdWordsAndChars()
Dim NumChars As Integer
Dim NumChars2 As Integer
Dim NumWords As Integer
Dim strText As String
strText = Selection.Text
Call WordsAndChars(strText, NumWords, NumChars, NumChars2, True)
End Sub
Sub WordsAndChars(strText As String, NumWords As Integer, NumChars, NumChars2, _
Optional DisplayResults As Boolean = True)
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)
Dim Item As Variant
Dim strItems() As String
Dim strTemp As String
strTemp = strBuffer
strItems = Split(strTemp, Delim)
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
Dim OrigLen As Long
If Num < 0 Then
MsgBox "RemoveExtra: value for Num is not valid", "vbCritical + vbOKOnly"
Exit Function
End If
RemoveExtra = strText
Do Until Len(RemoveExtra) = OrigLen
OrigLen = Len(RemoveExtra)
RemoveExtra = Replace(RemoveExtra, String(Num + 1, Char), String(Num, Char))
Loop
End Function
|