在阵列VBA中计数值

debugcn 发表于 Dev

Tor00845

我有两个数组：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是问题，因此非常感谢任何有关如何解决它的建议！谢谢！

VBasic2008

词典唯一

第一个代码执行您要的操作，但是第二个代码执行此操作而没有第二个数组。两种解决方案都有其优点和缺点。

编码

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。