CODEWITHSUNDEEP
vbaexcel
Ibra22
Ibra22

Reputation: 25

How to count repeating values in an array (VBA)?

Assume I have an array that has the following data:

apples
apples
apples
apples
oranges
grapes
oranges
apples
oranges
grapes
bananas

How can I make the output look like this:

Item        count
apples        5
oranges       3
grapes        2
bananas       1

I am not looking for a pivot table solution, but rather a code in VBA.

Thanks in advance for all your help.

Current Code I am using the following:

'Setting Up Dynamic Array to Store Fruit Selections
Dim MyArray() As Variant


'Counting # of Rows
Dim lRow As Long
lRow = ws.Range("A13", ws.Range("A13").End(xlDown)).Rows.Count


'Resize Array
ReDim MyArray(lRow)


For i = 1 To lRow
    MyArray(x) = ws.Cells(i + 12, 11)
    x = x + 1
Next

Now that I have stored all the fruit values in the array, how can I count the number of unique fruits and their respective count?

Upvotes: 0

Views: 1115

Answers (1)

QHarr
QHarr

Reputation: 84465

Here is a dictionary method. I note you are using column A for finding last row but that your fruits, I believe, are in column K. Each time a key is encountered again in the dictionary 1 is added to the existing value for that key:

fruitDict(.Cells(i + 12, 11).Value) = fruitDict(.Cells(i + 12, 11).Value) + 1

Code:

Option Explicit
Public Sub TEST()
    Dim MyArray() As Variant, ws As Worksheet, lRow As Long, fruitDict As Object, i As Long
    Set fruitDict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With ws
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Select Case lRow
        Case Is < 13
            Exit Sub
        Case 13
            ReDim MyArray(1, 1)
            MyArray = .Range("A13").Value
        Case Else
            MyArray = .Range("A13:A" & lRow).Value
        End Select

        For i = LBound(MyArray, 1) To UBound(MyArray, 1)
            If Not IsEmpty(.Cells(i + 12, 11)) Then
                fruitDict(.Cells(i + 12, 11).Value) = fruitDict(.Cells(i + 12, 11).Value) + 1
            End If
        Next
    End With

    With Worksheets("Sheet2")
        .Range("A1").Resize(fruitDict.Count, 1) = Application.WorksheetFunction.Transpose(fruitDict.keys)
        .Range("B1").Resize(fruitDict.Count, 1) = Application.WorksheetFunction.Transpose(fruitDict.Items)
    End With
End Sub

Upvotes: 1

Related Questions