数组 VBA 中的计数值

Question

我有两个数组：Arr1 有 11 个值，一些重复一些没有，Arr2 包含与 Arr1 相同的值，只是没有重复。当时的想法是使用 Countif 函数来计算 Arr2 中的值出现在 Arr1 中的次数，但我知道 countif 不适用于数组。

Arr1 包含 = A,A,B,C,A,D,E,E,F,F,G

Arr2 包含 = A,B,C,D,E,F,G

理想情况下，代码会在一列中输出 Array2，在另一列中输出相应的计数，如下所示：

Col R    Col S
A        3
B        1
C        1
D        1
E        2
F        2
G        1

这是我编写的代码，但仅适用于一个值：

Cells(1, 18).Resize(UBound(Arr2)).Value = Application.Transpose(Arr2)

Dim count As Integer
Dim i As Double

For i = 1 To 7
       count = count + Abs(Arr1(i) = "A")
Next i
Range("S1") = count

如果我尝试通过添加数组来循环遍历数据，则会收到“超出范围”错误。

Cells(1, 18).Resize(UBound(Arr2)).Value = Application.Transpose(Arr2)

Dim count As Integer
Dim i As Double

For i = 1 To 7
       count = count + Abs(Arr1(i) = Arr2(i))

Cells(i, "S") = count

Next i

我不太确定哪里出错了，我假设添加 Arr2 是问题所在，因此非常感谢任何有关如何修复它的建议！ 谢谢！

Answer 1

您需要第三个数组（也可以使用范围）来存储结果和两个嵌套的 for 循环。 这是一个例子

Sub TestA()

    Dim A1(), A2(), A3(), A As Variant, B As Variant
    Dim I As Long
    
    A1 = Array(1, 2, 1, 2, 3, 3, 3, 4, 5, 5, 6)
    A2 = Array(1, 2, 3, 4, 5, 6)
    ReDim A3(LBound(A2) To UBound(A2))
    I = LBound(A2)
    For Each A In A2
        For Each B In A1
            A3(I) = A3(I) + IIf(A = B, 1, 0)
        Next B
        I = I + 1
    Next A
    
End Sub

Answer 2

您可以在此处使用 scripting.dictionary。这样，您只需要使用第一个数组就可以取消第二个数组。代码如下：sn-p：

Option Explicit

Sub count_array()

Dim arr As Variant
Dim i As Integer
Dim dict As Scripting.Dictionary
Dim k

' specify array
arr = Array("A", "A", "B", "C", "A", "D", "E", "E", "F", "F", "G")

' loop through records and increment for each instance
Set dict = New Scripting.Dictionary
For i = LBound(arr) To UBound(arr)
    If Not dict.Exists(arr(i)) Then
        dict.Add arr(i), 1
    Else
        dict(arr(i)) = dict(arr(i)) + 1
    End If
Next i

' how to loop through each key
For Each k In dict
    Debug.Print k, dict(k)
Next k

End Sub

请记住在工具 > 参考下添加“Microsoft 脚本运行时”参考。这将输出：

A              3 
B              1 
C              1 
D              1 
E              2 
F              2 
G              1 

Answer 3

您可以使用字典来提取唯一列表并跟踪计数。

在下面的代码中，我从工作表范围创建了 VBA 数组，但您也可以直接创建它：

例如：Array("A","A","B","C","A","D","E","E","F","F","G")

如果这是在工作表上，您可以只使用公式来创建列。

Option Explicit
Function countIt(rg1 As Range)
    Dim v, w
    Dim D As Object
    
Set D = CreateObject("Scripting.Dictionary")
    D.CompareMode = TextCompare
    
v = rg1
For Each w In v
    If Not D.Exists(w) Then
        D.Add w, 1
    Else
        D(w) = D(w) + 1
    End If
Next w

Dim x, I As Long
ReDim x(1 To D.Count, 1 To 2)

For Each w In D.Keys
    I = I + 1
    x(I, 1) = w
    x(I, 2) = D(w)
Next w

countIt = x
End Function

Answer 4

字典唯一

第一个代码执行您要求的操作，但第二个代码在没有第二个数组的情况下执行此操作。这两种解决方案各有利弊。

守则

Option Explicit

Sub writeUniqueWithCount()
    
    Const tgtName As String = "Sheet1"
    Const tgtFirstCell As String = "A1"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    Dim Arr1 As Variant
    Arr1 = Array("A", "A", "B", "C", "A", "D", "E", "E", "F", "F", "G")
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim j As Long
    For j = LBound(Arr1) To UBound(Arr1)
        dict(Arr1(j)) = dict(Arr1(j)) + 1
    Next
    
    Dim Arr2 As Variant
    Arr2 = Array("A", "B", "C", "D", "E", "F", "G")
    
    Dim NoE2 As Long
    NoE2 = UBound(Arr2) - LBound(Arr2) + 1
    Dim RowOffset As Long
    RowOffset = 1 - LBound(Arr2)
    Dim Result As Variant
    ReDim Result(1 To NoE2, 1 To 2)
    Dim i As Long
    
    For i = 1 To NoE2
        Result(i, 1) = Arr2(i - RowOffset)
        Result(i, 2) = dict(Result(i, 1))
    Next i
    
    Dim rng As Range
    Set rng = wb.Worksheets(tgtName).Range(tgtFirstCell)
    rng.Resize(UBound(Result, 1), UBound(Result, 2)).Value = Result
 
    MsgBox "Wrote unique."

End Sub

Sub writeUniqueWithCountOneArray()
    
    Const tgtName As String = "Sheet1"
    Const tgtFirstCell As String = "A1"
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    Dim Arr1 As Variant
    Arr1 = Array("A", "A", "B", "C", "A", "D", "E", "E", "F", "F", "G")
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim j As Long
    For j = LBound(Arr1) To UBound(Arr1)
        dict(Arr1(j)) = dict(Arr1(j)) + 1
    Next
    Dim Result As Variant
    ReDim Result(1 To dict.Count, 1 To 2)
    
    Dim Key As Variant
    Dim i As Long
    For Each Key In dict.Keys
        i = i + 1
        Result(i, 1) = Key
        Result(i, 2) = dict(Key)
    Next Key
    
    Dim rng As Range
    Set rng = wb.Worksheets(tgtName).Range(tgtFirstCell)
    rng.Resize(UBound(Result, 1), UBound(Result, 2)).Value = Result
 
    MsgBox "Wrote unique."

End Sub

Answer 5

最好使用 Scripting.DIctionary 来编译频率计数

Dim myFreq as Scripting.Dictionary
Set myFreq = New Scripting.Dictionary

Dim myKey as Variant
For each myKey in Split("A,A,B,C,A,D,E,E,F,F,G",",")

    If not myFreq.Exists(myKey) then
    
        myFreq.Add myKey,1

    else

        myFreq.Item(myKey)=myFreq.Item(myKey)+1
 
    End if

Next

然后您可以遍历第二个数组进行检查

For each myKey in SPlit("A,B,C,D,E,F,G",",")

    If MyFreq.Exists(myKey) then
 
        Debug.Print myKey, myFreq.Item(mykey)

    Else

        Debug.Print myKey,0

    end if

Next