VBA alternative to the countif formula

[JonnyEnglish]

Hey guys,
Is there an alternative to the countif formula I have used in the attached spreadsheet that won’t cause excel to crash whenever I import new decks? (I often import 1000+ decks at a time)

[thatandyward]

The trick to dealing with large data sets is to put all the data into, and process it as, an array. Constantly writing to/from the worksheet takes orders of magnitude longer than manipulating the data in array form. The other trick is to minimize the number of times you have to loop the array.

See if this works for you…

Sub CountUniques()

    Dim CardNames() As Variant, NewDecks() As Variant
    Dim i As Long, j As Long, k As Long
    Dim NotFound As New Collection, Element As Variant

    With Sheet1
    
        'store new decks into array for processing
        NewDecks = .Cells(3, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 2, 12).Value
        
        'reset cell styles to normal
        .Cells(3, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 2, 12).Style = "Normal"
    
    End With
    
    With Sheet2
        
        'store card names into array
        CardNames = Application.Transpose(.Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row).Value)
    
    End With
    
    'create & size array to store counts
    ReDim NameCounts(1 To UBound(CardNames))
    
    'loop rows
    For i = LBound(NewDecks, 1) To UBound(NewDecks, 1)
    
        'loop cols
        For j = LBound(NewDecks, 2) To UBound(NewDecks, 2)
        
            'only process if data
            If Not IsEmpty(NewDecks(i, j)) Then
    
                'check current name exists & retrieve index #
                If Not IsError(Application.Match(NewDecks(i, j), CardNames, 0)) Then
                
                    'assign index#
                    k = Application.Match(NewDecks(i, j), CardNames, 0)
                    
                    'add count to NameCounts
                    NameCounts(k) = NameCounts(k) + 1
                
                Else 'not found
                    
                    'save row/col position of not found
                    NotFound.Add i & "_" & j
                
                End If
            
            End If
            
        Next j
    
    Next i
    
    'output counts to sheet2 col B
    With Sheet2
        .Cells(1, 2).Resize(UBound(NameCounts)) = Application.Transpose(NameCounts)
    End With
    
    'highlight not found
    With Sheet1
        For Each Element In NotFound
            .Cells(CInt(Split(Element, "_")(0)) + 2, CInt(Split(Element, "_")(1))).Style = "Bad"
        Next Element
    End With

End Sub

This will take data from Sheet1 (assumes always cols A>L, starting at row 3) and then output the count for each name on Sheet2 next to the name list you had there. It will also highlight any entries that didn't match (in case of typos etc).

I have uploaded a modified file with the code already included. I removed all the COUNTIF formulas you had on Sheet1 and fixed the formula you had in col C to calc the percentages (you needed absolute references for COUNTA)

[xladept]

Hi jonny,

I made the headers totals just the sum:

=SUM(O$3:O$27)

and an array for the rest:

Sub jonny(): Dim r As Long, c As Long, x As Long, D, Z, Card As String, n As Long
r = Rows.Find("*", , , , xlByRows, xlPrevious).Row
c = Columns.Find("*", , , , xlByColumns, xlPrevious).column
Range("N3").Resize(r - 2, c - 13).ClearContents
D = Range("A3").Resize(r - 2, 12): Z = Range("N2").Resize(r - 1, c - 13)
For c = LBound(Z, 2) To UBound(Z, 2)
For r = 1 To UBound(D): Card = Z(1, c)
For x = LBound(D, 2) To UBound(D, 2)
If D(r, x) = Card Then n = n + 1
Next x:
Z(r + 1, c) = n: n = 0
Next r
Next c
Range("N2").Resize(r, c - 1) = Z
End Sub

[jindon]

Here's how I interpret your problem.

Sub test()
    Dim a, e, i As Long, ii As Long, ub As Long, dic As Object, w
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Range("a2").CurrentRegion
        a = .Offset(, .Range("a2").MergeArea.Columns.Count + 1).Resize(, .Columns.Count _
            - .Range("a2").MergeArea.Columns.Count - 1).Value: ub = .Rows.Count - 2
        For ii = 1 To UBound(a, 2)
            If a(2, ii) <> "" Then
                ReDim w(1 To UBound(a, 1))
                dic(a(2, ii)) = w
            End If
        Next
        a = .Resize(, .Range("a2").MergeArea.Columns.Count).Value
    End With
    For i = 3 To UBound(a, 1)
        For ii = 1 To UBound(a, 2)
            If a(i, ii) <> "" Then
                w = dic(a(i, ii)): w(i) = 1: dic(a(i, ii)) = w
            End If
    Next ii, i
    For Each e In dic
        dic(e) = Application.Sum(dic(e))
    Next
    With Sheets("sheet2").Cells(1).Resize(dic.Count, 2)
        .CurrentRegion.ClearContents
        .Value = Application.Transpose(Array(dic.keys, dic.items))
        With .Columns(3)
            .Formula = "=if(b1>0,b1/" & ub & ",0)"
            .NumberFormat = "0%"
        End With
        .Columns.AutoFit
    End With
End Sub

[bakerman2]

This one counts per row like your CountIf formulas do.

Sub tst()
    With Sheets("sheet1")
        .Range("N3:HOA27").ClearContents
        sn = .Range("a2").CurrentRegion.Offset(1).Value
        sn2 = .Range("N2").CurrentRegion.Offset(1).Resize(UBound(sn)).Value
        sp = .Range("N2:HOA2").Value
        For i = 1 To UBound(sn, 1)
            For ii = 1 To UBound(sn, 2)
                If sn(i, ii) <> vbNullString Then
                    k = Application.Match(sn(i, ii), sp, 0)
                    If Not IsError(k) Then
                        sn2(i + 1, k) = sn2(i + 1, k) + 1
                    End If
                End If
            Next
        Next
        .Range("N2").Resize(UBound(sn2, 1), UBound(sn2, 2)) = sn2
    End With
End Sub

@ Orrin

Missed your Post so my solution is somewhat similar to yours.
Only difference is that yours is slightly faster.

[JonnyEnglish]

Thank you for all the fantastic solutions!

Thatandyward, I’m really grateful for the additional explanation, comments and functionality

[thatandyward]

Glad it was of use.

Not sure if you also need to sum by row on Sheet1? I assumed these were just helper cells to calculate the totals on Sheet2 so I didn't factor them into my original solution; however if you do need them then the updated code below will also output them.

Sub CountUniques()

    Dim CardNames() As Variant, NewDecks() As Variant
    Dim i As Long, j As Long, k As Long
    Dim NotFound As New Collection, Element As Variant

    With Sheet1
    
        'store new decks into array for processing
        NewDecks = .Cells(3, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 2, 12).Value
        
        'reset cell styles to normal
        .Cells(3, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 2, 12).Style = "Normal"
    
    End With
    
    With Sheet2
        
        'store card names into array
        CardNames = Application.Transpose(.Cells(1, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row).Value)
    
    End With
    
    'create & size array to store counts
    ReDim NameCounts(1 To UBound(CardNames)) As Long
    
    'create & size array to store by row counts
    ReDim ByRowCounts(1 To UBound(NewDecks, 1), 1 To UBound(CardNames)) As Long
    
    'loop rows
    For i = LBound(NewDecks, 1) To UBound(NewDecks, 1)
    
        'loop cols
        For j = LBound(NewDecks, 2) To UBound(NewDecks, 2)
        
            'only process if data
            If Not IsEmpty(NewDecks(i, j)) Then
    
                'check current name exisits & retrieve index #
                If Not IsError(Application.Match(NewDecks(i, j), CardNames, 0)) Then
                
                    'assign index#
                    k = Application.Match(NewDecks(i, j), CardNames, 0)
                    
                    'add count to NameCounts
                    NameCounts(k) = NameCounts(k) + 1
                    
                    'add count to by row count
                    ByRowCounts(i, k) = ByRowCounts(i, k) + 1
                
                Else 'not found
                    
                    'save row/col position of not found
                    NotFound.Add i & "_" & j
                
                End If
            
            End If
            
        Next j
    
    Next i
    
    'output counts to sheet2 col B
    With Sheet2
        .Cells(1, 2).Resize(UBound(NameCounts)) = Application.Transpose(NameCounts)
    End With
    
    
    With Sheet1
    
        'output by row counts
        .Cells(2, 14).Resize(, UBound(CardNames)) = CardNames
        .Cells(3, 14).Resize(UBound(ByRowCounts, 1), UBound(ByRowCounts, 2)) = ByRowCounts
    
        'highlight not found
        For Each Element In NotFound
            .Cells(CInt(Split(Element, "_")(0)) + 2, CInt(Split(Element, "_")(1))).Style = "Bad"
        Next Element
        
    End With

End Sub

[xladept]

@ bakerman2 - That's not the only difference, yours' is more elegant

@ jonny - You're welcome - what a selection!

If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.

[JonnyEnglish]

one last question - is there a way to remove the helper columns but still use the data to create a table similar to the one below on sheet 2? I gave it a go but I could only get the sum for the entire array called “ByRowCounts” – I can’t figure out how to deal with multi-dimensional arrays

Card Name	Total used	%	number of decks that use the card	%
Marrow Weaver	6	0.24	4	0.16
Vile Darter	29	1.15	10	0.4
Zoid Battered	11	0.44	8	0.32
Irvos Mistwalker	7	0.28	5	0.2
Alpha Replicant	9	0.36	9	0.36
Therion Aetherstorm	4	0.16	4	0.16
Typhon's Pupil	2	0.08	2	0.08
Airspace Regulators	5	0.2	3	0.12
Sif's Evangel	3	0.12	3	0.12
Alpha Slayer	3	0.12	3	0.12
Typhon the Insane	8	0.32	8	0.32
Atomic Wardriver	11	0.44	7	0.28
Exicon Vanisher	4	0.16	4	0.16
Selciscorpion	5	0.2	5	0.2
Aerial Ocelot	0	0	0	0
Atmos Flyer	0	0	0	0
Windstorm Successor	1	0.04	1	0.04
Pherous Astute	0	0	0	0
Dune Runner	2	0.08	2	0.08
Daedalus Enraged	5	0.2	5	0.2

Just wanted to say thank you again for all the help I’ve received so far – I think I’ll be spending a lot time getting to grips with vba from now on after seeing how useful it is

[xladept]

Looks like a modification to Jindon's code would do the trick

[jindon]

Sub test()
    Dim a, e, i As Long, ii As Long, ub As Long, dic As Object
    Dim w, x, sumTotal As Long, sumDeck As Long
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Sheets("sheet1").Range("a2").CurrentRegion
        a = .Offset(, .Range("a2").MergeArea.Columns.Count + 1).Resize(, .Columns.Count _
            - .Range("a2").MergeArea.Columns.Count - 1).Value: ub = .Rows.Count - 2
        ReDim w(1 To 5): ReDim x(1 To UBound(a, 1)): w(2) = 0: w(4) = x
        For ii = 1 To UBound(a, 2)
            If a(2, ii) <> "" Then
                w(1) = a(2, ii): dic(a(2, ii)) = w
            End If
        Next
        a = .Resize(, .Range("a2").MergeArea.Columns.Count).Value
    End With
    For i = 3 To UBound(a, 1)
        For ii = 1 To UBound(a, 2)
            If a(i, ii) <> "" Then
                w = dic(a(i, ii)): w(2) = w(2) + 1
                x = w(4): x(i) = 1: w(4) = x
                dic(a(i, ii)) = w
                sumTotal = sumTotal + 1
            End If
    Next ii, i
    For Each e In dic
        w = dic(e): w(4) = Application.Sum(w(4))
        dic(e) = w: sumDeck = sumDeck + w(4)
    Next
    With Sheets("sheet2").Cells(1).Resize(, 5)
        .CurrentRegion.ClearContents
        .Value = Array("Card Name", "Total used", "%", "number of decks" & vbLf & "that use the card", "%")
        With .Rows(2).Resize(dic.Count, 5)
            .Value = Application.Index(dic.items, 0, 0)
            .Columns(3).Formula = "=if(b2=0,0,b2/" & sumTotal & ")"
            .Columns(3).NumberFormat = "0.00%"
            .Columns(5).Formula = "=if(d2=0,0,d2/" & sumDeck & ")"
            .Columns(5).NumberFormat = "0.00%"
        End With
        .CurrentRegion.Columns.AutoFit
    End With
End Sub

[JonnyEnglish]

Thank you Jindon!

[jindon]

You are welcome and thanks for the rep.