Counting words in multiple sentences

Try this for results in columns "B" & " C".

Sub MG16Nov10
Dim Rng As Range, Dn As Range, n As Long
Dim Sp As Variant
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
For Each Dn In Rng
    Sp = Split(Dn.Value, " ")
        For n = 0 To UBound(Sp)
            If Not .Exists(Sp(n)) Then
                .Add Sp(n), 1
            Else
                .Item(Sp(n)) = .Item(Sp(n)) + 1
            End If
        Next n
Next
Range("B2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
End With
End Sub

Regards Mick

Thanks for the nice macro, Mick.
It does the job!
When I looked at the results I realized that it will be a lot more useful if:

1. The macro will filter out the question mark sign (?)
at the moment LICE and LICE? are counted as two different words, I need to remove the ? sign from the calculations and count the total amount of instances of each word into a single result.
2. there are 29 words that needs to be excluded from the results, see text file attached.

Thanks again,
Sami

Originally Posted by MickG

Try this for results in columns "B" & " C".

Sub MG16Nov10
Dim Rng As Range, Dn As Range, n As Long
Dim Sp As Variant
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
For Each Dn In Rng
    Sp = Split(Dn.Value, " ")
        For n = 0 To UBound(Sp)
            If Not .Exists(Sp(n)) Then
                .Add Sp(n), 1
            Else
                .Item(Sp(n)) = .Item(Sp(n)) + 1
            End If
        Next n
Next
Range("B2").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
End With
End Sub

Regards Mick

BINGO!
Thanks a lot, Mick!
Sami

Originally Posted by MickG

Try this:-
Nb:- Add to "Excluded" words list as required.

Sub MG16Nov11
Dim Rng As Range, Dn As Range, n As Long
Dim Sp As Variant, nn As Integer
Dim Wds As Variant, Dic As Object, Qn As String

Wds = Array("which", "who", "arent", "why", "isn't", "how", "what", "when", "where", "which", "who", _
"whom", "whose", "wouldn't", "would", "won't", "will", "shouldn't", "should", "couldn't", "must", "might", _
"could", "may", "can't", "didn't", "can", "Do", "Does")

Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
      .CompareMode = vbTextCompare
        For n = 0 To UBound(Wds): .Item(Wds(n)) = Empty: Next n
            Set Dic = CreateObject("scripting.dictionary")
                Dic.CompareMode = vbTextCompare

For Each Dn In Rng
    Sp = Split(Dn.Value, " ")
        For n = 0 To UBound(Sp)
            Qn = IIf(Right(Sp(n), 1) = "?", Left(Sp(n), Len(Sp(n)) - 1), Sp(n))
            If Not .exists(Qn) Then
                If Not Dic.exists(Qn) Then
                    Dic.Add Qn, 1
                Else
                    Dic.Item(Qn) = Dic.Item(Qn) + 1
                End If
            End If
        Next n
Next
Range("B2").Resize(.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
End With
End Sub

Regards Mick

You're welcome