Excel VBA字符匹配计数修复

Question

我在下面的代码位置非常接近我期望的位置。工作原理是在excel电子表格中按下“List Word Issue”按钮，然后逐个单元格扫描所有文本，并逐行扫描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添加到模块的顶部。这将有助于调试。

...你不几乎从来没有使用激活什么...

....你知道吗？我会完全使用不同的方法。我不喜欢这个代码是诚实的。

我知道我们不鼓励提供一个全面的解决方案，但我不喜欢这样散布的不那么好的代码（从道格拉斯链接的网站，不一定是道格拉斯写的）。

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

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