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