根据数组索引值增加不同的计数器

Question

我在一个工作表(称为MainDump(中有一个庞大的数据列表。我设置了一个程序来评估这个列表，并使用以下设置返回某些值：

Dim ws1 As Worksheet
Set ws1 = Worksheets("DashBoard")
Dim ws2 As Worksheet
Set ws2 = Worksheets("MainDump")
Dim cntr As Long
On Error GoTo ErrorHandler 'Got A lot of divide by zero errors if searchstring wasn't found
With Application.WorksheetFunction            
ws1.Range("O4").Value = .CountIf(ws2.Range("E:E"), "*" & "CEOD" & "*")
ws1.Range("L4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("A:A"), "Yes") / ws1.Range("O4").Value
ws1.Range("M4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("B:B"), "Yes") / ws1.Range("O4").Value
ws1.Range("N4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("C:C"), "SA Present, WBDA Present") / ws1.Range("O4").Value
End With
cntr = cntr + 1        
'^This proces is then copied and thus repeated a total of 76 times, as I want to check 
'for 76 different values in ws2.Range("E:E"), resulting in a massive code
ErrorHandler:
If Err.Number = 6 Then
If ws1.Range("O" & cntr).Value = 0 Then
ws1.Range("L" & cntr).Value = "div. by zero"
ws1.Range("M" & cntr).Value = "div. by zero"
ws1.Range("N" & cntr).Value = "div. by zero"
End If
End If
Resume Next

我写这篇文章的时候，我在VBA方面的经验要少得多。不用说，此代码需要花费大量时间才能完成(Maindump计数约98000行(。所以我想尝试通过数组来完成这项工作。

我的方法是为我想在数组索引中检查的每个字符串定义一个计数器，然后在数组中循环并在数组中找到字符串时增加相应的计数器。我的问题是，是否有一种方法可以用以下形式编写循环：

Dim LastRow1 As long
Dim DataArray() As Variant
Dim SearchString1, SearchString2, .... SearchString76 As String
Dim SearchString1Cntr, SearchString2Cntr, .... SearchString76Cntr As long
With ws2
LastRow1 = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row 'Gets the total row amount in the sheet
DataArray = .Range("A3:E" & LastRow1) 'puts selected range in Array
End With
For LastRow1 = Lbound(DataArray, 1) to Ubound(DataArray, 1)
'Start a For Each loop to check for all 76 strings
If Instr(1, DataArray(LastRow1, 5), SearchString > 0 Then 'SearchString is found so then
SearchStringCntr1 = SearchStringcntr1 + 1 
'Where SearchStrinCntr1 is the counter related to the string checked for in the loop, 
'so it switches when the SearchString changes
End If
'Next SearchString to check
Next LastRow1

因此，我想尝试在For Next循环中使用灵活的If语句，该语句检查每个SearchString的Array索引，然后在循环到下一个索引之前，如果在索引中找到SearchString，则递增相应的SearchStringCntr。这可能吗？我想防止为每个SearchString+StringCntr生成76个不同的If/ElseIf语句，然后在每次代码循环for LastRow1/Next LastRow1循环时使用计数器循环它们。很想听听你的意见。

Answer 1

也许这会有所帮助(可能需要一些调整(
在工作簿中的某个位置创建命名范围"字符串"，用于存储要查找的所有字符串

Option Explicit
Sub StringsCompare()
Dim LastRow1 As Long
Dim DataArray() As Variant, StringArray() As Variant
Dim Ws2 As Worksheet
Dim CompareStringsNo As Long, StringCounter As Long
Dim i As Long, j As Long
Dim aCell As Range
Dim SourceStr As String, SearchStr As String
Set Ws2 = ThisWorkbook.Sheets("Sheet1")
StringCounter = 1
With Ws2
'fill array with your strings to compare
CompareStringsNo = .Range("Strings").Rows.Count
ReDim StringArray(1 To CompareStringsNo, 1 To 2)
For Each aCell In .Range("Strings")
StringArray(StringCounter, 1) = aCell.Value
StringCounter = StringCounter + 1
Next aCell
'fill data array
LastRow1 = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row 'Gets the total row amount in the sheet
DataArray = .Range("A1:E" & LastRow1)
End With
'search data array
For i = LBound(DataArray, 1) To UBound(DataArray, 1)
SourceStr = DataArray(i, 5)
'search array with your strings
For j = LBound(StringArray) To UBound(StringArray)
SearchStr = StringArray(j, 1)
If InStr(1, SourceStr, SearchStr) > 0 Then
'if match is found increase counter in array
StringArray(j, 2) = StringArray(j, 2) + 1
'you can add exit for here if you want only first match
End If
Next j
Next i
For i = LBound(StringArray) To UBound(StringArray)
Debug.Print StringArray(i, 1) & " - " & StringArray(i, 2)
Next i
End Sub

Answer 2

我认为主要任务过于复杂。

要检查字符串在数组中出现的次数，可以使用以下函数：

Function OccurWithinArray(theArray As Variant, stringToCount As String) As Long
Dim strArr As String
strArr = Join(theArray, " ")
OccurWithinArray = (Len(strArr) - Len(Replace(strArr, stringToCount, _
vbNullString, , , vbTextCompare))) / Len(stringToCount)
End Function

以及演示：

Sub Demo()
Dim test(1 To 3) As String
test(1) = "I work at the Dog Pound."
test(2) = "I eat dogfish regularly."
test(3) = "Steroidogenesis is a thing."
Debug.Print OccurWithinArray(test, "dog")
End Sub

---

如何工作:

Join将数组的所有元素连接成一个大字符串。Len返回文本的长度
Replace临时替换，删除所有出现的搜索词
Len返回文本的"修改"长度
两个Len之间的差值除以要搜索的字符串的长度，即字符串在整个数组中的出现次数。

---

由于搜索区分大小写，因此返回3。

要使搜索区分大小写，请删除单词vbTextCompare(在这种情况下，此示例将返回2(