计算数组中的值 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。这样一来，您只需要使用第一个数组，而无需使用第二个数组。请参阅下面的代码片段：

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 Scripting Runtime”参考。这将输出：

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

计算数组中的值 VBA

Counting Values in Array VBA

arrays

excel

vba

countif

唯一词典