Excel VBA 单词匹配计数修复

Question

我在下面的这段代码非常接近我想要做的事情。它的工作原理是您按下 Excel 电子表格中的“列出单词问题”按钮，它会逐个单元格地扫描 A 列中的所有文本，逐行扫描包含单词列表的单独工作表。如果存在匹配项（在第 1 列中每个单独单元格中的内容之间），则它将匹配的单词放入 b 列中的相邻行中。

此处 (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) 是我在其中找到代码的文章的链接，以及用于下载整个 .xls 电子表格的链接 (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls)。

我正在寻找的是一个简单的更改，因此除非该单词在第一个工作表的 A 列的每个单元格/行中出现至少 5 次，否则不会有“匹配”。

    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

如果您有兴趣，请快速评论一些代码：

Dim lngLoop, lngLastRow As Long

lngLoop 实际上是 Variant，不是很长。不幸的是，你不能像在 C++ 中那样声明数据类型。

您需要这样做：

Dim lngLoop As Long, lngLastRow As Long

另外，WordIssue 从未使用过。应该是vrWordIssue。

事实上，我几乎从不将 Variant 用于 VBA 中的任何内容。我不相信该网站的这个作者知道大量的 VBA。 （至少，不是他们写的时候）

也就是说，我要修复的第一件事是变量：

发件人：

Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range

收件人：

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

并将Option Explicit 添加到模块顶部。这将有助于调试。

...而且您几乎不必为任何事情使用激活...

....你知道吗？我会完全使用不同的方法。老实说，我不喜欢这段代码。

我知道不鼓励提供完整的解决方案，但我不喜欢这样传播不太好的代码（来自 Douglas 链接的网站，不一定是 Douglas 写的）。

这就是我要做的。顺便说一下，这会检查区分大小写的问题词。

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