Excel VBA word match count fix - excel

Question

I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub

Answer 1

Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub