Counting Values in Array VBA

Question

I have two arrays: Arr1 that has 11 values, some duplicate some not, and Arr2 that contains the same values as Arr1, just without the duplicates. The thought was to use the Countif function to count how many times the values in Arr2 appear in Arr1, but I know countif doesn't work with arrays.

Arr1 contains = A,A,B,C,A,D,E,E,F,F,G

Arr2 contains = A,B,C,D,E,F,G

Ideally, the code would output Array2 in one column and the corresponding count in another column, something that looks like:

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

This is the code that I made that works but only for one value:

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

If I try to loop through the data with adding an Array, I get an "Out of Range" error.

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

I'm not too sure where I'm going wrong, I'm assuming adding Arr2 is the issue so any advice on how to fix it is greatly appreciated! Thanks!

You will need to nest two loops. Loop the 2nd array, then loop the first finding where it is equal. — Scott Craner
– Scott Craner, Commented Sep 28, 2020 at 20:41

VBasic2008 · Accepted Answer · 2020-09-28 21:06:45Z

Dictionary Unique

The first code does what you asked for, but the second code does this without the second array. Both solutions have its pros and cons.

The Code

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

Zer0Kelvin · Accepted Answer · 2020-09-28 20:48:53Z

0

You need a third array (you can also use range) for the results and two nested for loops. This is one example

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

answered Sep 28, 2020 at 20:48

Zer0Kelvin

3742 silver badges7 bronze badges

Comments

coross24 · Accepted Answer · 2020-09-28 20:54:44Z

You could use the scripting.dictionary here. That way, you would only need to use the first array and could do away with the second. See below for a code snippet:

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

Just remember to add the "Microsoft Scripting Runtime" reference under Tools > References. This would then output:

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

Ron Rosenfeld · Accepted Answer · 2020-09-28 20:56:28Z

You can use a dictionary to both extract the unique list and also keep track of the count.

In the code below I created the VBA array from a worksheet range, but you could just as easily create it directly:

eg: Array("A","A","B","C","A","D","E","E","F","F","G")

And if this were on a worksheet, you could just use formulas to create the columns.

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

freeflow · Accepted Answer · 2020-09-28 21:08:34Z

0

Compiling the frequency count is best done with a 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

You can then iterate over the second array to check

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

answered Sep 28, 2020 at 21:08

freeflow

4,3753 gold badges13 silver badges19 bronze badges

Collectives™ on Stack Overflow

Counting Values in Array VBA

5 Answers 5

Dictionary Unique

1 Comment

Comments

Comments

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

5 Answers 5

Dictionary Unique

1 Comment

Comments

Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related