(Solved) – Universal VBA Word Count for Excel

  • by

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, "  ", " ")

    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

Leave a Reply

Your email address will not be published. Required fields are marked *