CODEWITHSUNDEEP
arraysexcelvbacountif
Alessio_110
Alessio_110

Reputation: 143

CountIF within an Array VBA

This should be easy and I think I am almost there. I would like to count how many times an entry repeats itself within a certain array. The array will be populated from a range. Eventually if the number of the count is more than 4, I would like to insert "Excess", otherwise if less than 4, I would like to insert "Insufficient", else is "complete". Unfortunately, even though I have learnt to do these calculations without using Arrays, I find some difficulties when switching to Arrays.

How the code should look like

Sub test()
    Dim MyArray() As Variant, Countarrays() As Variant, Result() As Variant
    Dim r As Range
    Dim rows As Integer

    Worksheets("Sheet1").Activate
    Set r = Range("B2", Range("B1").End(xlDown))
    MyArray = Range("B2", Range("B1").End(xlDown))
    rows = Range("B2", Range("B1").End(xlDown)).Count

    For i = 0 To rows
        For j = 0 To rows
        Countarrays(i, 1) = WorksheetFunction.CountIf(r, MyArray(i))

        If (Countarrays(i, 1).value) > 4 Then Result(j, 1) = "Excess"
        ElseIf (Countarrays(i, 1).value) < 4 Then Result(j, 1) = "Insufficient"
        ElseIf (Countarrays(i, 1).value) = 4 Then Result(j, 1) = "Complete"
        Next j
    Next i

End Sub

Upvotes: 1

Views: 1757

Answers (1)

Damian
Damian

Reputation: 5174

This should do the trick:

Option Explicit
Sub Test()

    Dim MyArray, DictDuplicates As New Scripting.Dictionary, i As Long

    With ThisWorkbook.Sheets("Sheet1") 'change if needed
        MyArray = .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown))
        For i = LBound(MyArray) To UBound(MyArray) 'loop to store all the items and how many times do they repeat
            If Not DictDuplicates.Exists(MyArray(i, 2)) Then 'if doesn't exists will store it
                DictDuplicates.Add MyArray(i, 2), 1
            Else 'if it does exists will increment its item value
                DictDuplicates(MyArray(i, 2)) = DictDuplicates(MyArray(i, 2)) + 1
            End If
        Next i

        For i = LBound(MyArray) To UBound(MyArray) 'loop to give back the result
            Select Case DictDuplicates(MyArray(i, 2))
                Case Is > 4
                    MyArray(i, 1) = "Excess"
                Case Is = 4
                    MyArray(i, 1) = "Complete"
                Case Is < 4
                    MyArray(i, 1) = "Insufficient"
            End Select
        Next i
        .Range(.Cells(2, 1), .Cells(2, 2).End(xlDown)) = MyArray
    End With

End Sub

Note that for the DictDuplicates to work, you need to check the Microsoft Scripting Runtime library.

Upvotes: 1

Related Questions