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