Universal VBA Word Count for Excel - excel

Question

I was trying to create a universal, error resistant VBA code that would count words in selected ranges as MS Word does. This below is the best I could do and I was hoping that somebody would have a look and let me know if I missed something or suggest any improvements. The code is quite fast and works with single cell, non-adjacent cells and whole columns, I need it to be as universal as possible. I'll be looking forward to feedback.
Option Explicit
Sub word_count()
Dim r() As Variant 'array
Dim c As Long 'total counter
Dim i As Long
Dim l As Long 'string lenght
Dim c_ch As Long 'character counter
Dim c_s As String 'string variable
Dim cell As range
Dim rng As range
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
ElseIf InStr(1, Selection.Address, ":", vbTextCompare) = 0 And InStr(1, Selection.Address, ",", vbTextCompare) = 0 Then 'for when only one cell is selected
word_count_f Selection.Value, c
MsgBox "Your selected cell '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
Exit Sub
ElseIf InStr(1, Selection.Address, ",", vbTextCompare) > 0 Then 'when user selects more than one cell by clicking one by one -> address looks like ('A1,A2,A3') etc
Application.ScreenUpdating = False
Dim help() As Variant
ReDim help(1 To Selection.Cells.Count)
i = 1
For Each cell In Selection 'loading straigh to array wouldn't work, so I create a helper array
help(i) = cell.Value
i = i + 1
Next cell
r = help
Else 'load selection to array to improve speed
Application.ScreenUpdating = False
r = Selection.Value
End If
Dim item As Variant
For Each item In r
word_count_f item, c
Next item
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
End Sub
Private Function word_count_f(ByVal item As Variant, ByRef c As Long)
Dim l As Long 'lenght variable
Dim c_s As String 'whole string variable
Dim c_ch As Long 'characted count variable
l = Len(item)
If l = 0 Then Exit Function
c_s = item
c_s = Trim(c_s)
Do While InStr(1, c_s, " ", vbTextCompare) > 0 'remove double spaces to improve accuracy
c_s = Replace(c_s, " ", " ")
Loop
If InStr(1, c_s, " ", vbTextCompare) = 0 And l > 0 Then 'if there was just one word in the cell
c = c + 1
ElseIf InStr(1, c_s, " ", vbTextCompare) > 0 Then 'else loop through string to count words
For c_ch = 1 To l 'loop through charactes of the string
If (Mid(c_s, c_ch, 1)) = " " Then
c = c + 1 'for each word
End If
Next c_ch
c = c + 1 'add one for the first word in cell
Else 'hopefully useless msgbox, but I wanted to be sure to inform the user correctly
MsgBox "Sorry, there was an error while processing one of the cells, the result might not be accurate", vbCritical
End If
End Function

Answer 1

You can achieve this in a similar way but with less code if you are interested to see?:
Sub word_count()
start_time = Timer
Dim r As Variant 'temp split array
Dim arr As Variant 'array
Dim c As Long 'total counter
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
Else
c = 0
For Each partial_selection In Split(Selection.Address, ",")
If Range(partial_selection).Cells.Count > 1 Then
arr = Range(partial_selection).Value
Else
Set arr = Range(partial_selection)
'single cell selected don't convert to array
End If
For Each temp_cell In arr
If Len(Trim(temp_cell)) > 0 Then
r = Split(temp_cell, " ")
For Each temp_word In r
If Len(Trim(temp_word)) > 0 Then
c = c + 1
'If the word is just a blank space don't count
End If
Next
'c = c + (UBound(r) - LBound(r) + 1)
'trimmed = Trim(temp_cell)
'c = c + 1 + (Len(trimmed) - Len(Replace(trimmed, " ", "")))
Else 'Blank cell
'Do nothing
End If
Next
Next
End If
Dim item As Variant
time_taken = Round(Timer - start_time, 3)
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") _
& "' in '" & Selection.Parent.Name & "' has " & c & " words." _
& vbNewLine & "Time Taken: " & time_taken & " secs"
Debug.Print c & " in "; time_taken; " secs"
End Sub

Answer 2

You could try this sort of approach? There may be the need to check for the next character to the space being another space, which would need some additions made. To detect word one as being the same as word one in the count. Also, transferring the range to an array would make it a touch faster.
Function Word_Count(rng As Excel.Range) As Long
Dim c As Excel.Range
Dim s As String
Dim l As Long
For Each c In rng.Cells
s = Trim(c.Value)
If s <> "" Then
If InStr(1, s, " ") > 0 Then
' Find number of spaces. You can use the ubound of split maybe here instead
l = l + (Len(s) - Len(Replace(s, " ", "")))
Else
End If
' Will always be 1 word
l = l + 1
End If
Next c
Word_Count = l
Set c = Nothing
End Function