Private Function CountWords(strText As String) As Long
    Dim x As Long
    Dim words As Long
    Dim lenStr As Long
    Dim lenPrevWord As Long
    Dim currentAscii As Integer
 
    ' Number of chars in string
    lenStr = Len(strText)
    ' Number of chars in the last word processed
    lenPrevWord = 0
 
    For x = 1 To lenStr
        ' ASCII value of the char being processed
        currentAscii = Asc(Mid$(strText, x, 1))
        Select Case currentAscii
            ' If current char is space (ASCII value 32)...
            Case 32
                ' ...and we have processed at least a char before
                ' then we have found a word
                If lenPrevWord > 0 Then
                    words = words + 1
                    ' Clear count of characters in previous word
                    lenPrevWord = 0
                End If
            Case Else
                ' If current char is not a space, then add 1 to the
                ' count of chars of the current word.
                lenPrevWord = lenPrevWord + 1                                     
        End Select
 
        ' Test if last char is other than a space.
        ' If so then there is a word.
        If x = lenStr And currentAscii <> 32 Then
            words = words + 1
        End If
    Next x
 
    CountWords = words
End Function

Private Sub CmdCount_Click()
    Dim MyCntArray
    Dim MyStr As String
    Dim i As Integer
    '
    MyStr = TextBox1.Text
    '
    For i = 2 To 10
        MyStr = Replace(MyStr, Space(i), Space(1))
    Next
    ' Replace All the multiple Spaces with single spaces 
    ' here i have given for max 10 spaces, 
    ' u can change it to a higher value
    '
    MyCntArray = Split(MyStr, " ")
    MsgBox "Number Of Words : " & UBound(MyCntArray) - 1
    '
End Sub