CODEWITHSUNDEEP
excelvba
Douglas
Douglas

Reputation: 3

Excel VBA word match count fix

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

Upvotes: 0

Views: 1382

Answers (1)

Joseph
Joseph

Reputation: 5160

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

Upvotes: 0

Related Questions