VBA take at least 1 test with over 350,000 rows

[Stephen_IV]

I have over 350,000 rows of data and need to count how many students per school who have taken at least 1 test. I have the data set below. Thanks in advance.

VBA Frequency Count if any test is taken.xlsm A B C D E F G H I J 1 School Name Test ID Start 2 AAA *****, ******* test 1 111 0 AAA 1 3 AAA *****, ******* test 2 111 0 BBB 2 4 AAA *****, ******* test 3 111 0 CCC 0 5 AAA *****, ******* test 4 111 0 6 AAA *****, ******* test 5 111 0 7 AAA *****, ******* test 6 111 0 8 AAA *****, ******* test 7 111 0 9 AAA *****, ******* test 8 111 0 10 AAA *****, ******* test 9 111 0 11 AAA *****, ******* test 10 111 0 12 BBB *****, ***** test 1 222 0 13 BBB *****, ***** test 2 222 1 14 BBB *****, ***** test 3 222 0 15 BBB *****, ***** test 4 222 1 16 BBB *****, ***** test 5 222 0 17 BBB *****, ***** test 6 222 0 18 BBB *****, ***** test 7 222 1 19 BBB *****, ***** test 8 222 0 20 BBB *****, ***** test 9 222 0 21 BBB *****, ***** test 10 222 0 22 AAA ********, ****** test 1 333 0 23 AAA ********, ****** test 2 333 0 24 AAA ********, ****** test 3 333 0 25 AAA ********, ****** test 4 333 0 26 AAA ********, ****** test 5 333 0 27 AAA ********, ****** test 6 333 0 28 AAA ********, ****** test 7 333 1 29 CCC ******, **** test 1 444 0 30 CCC ******, **** test 2 444 0 31 CCC ******, **** test 3 444 0 32 CCC ******, **** test 4 444 0 33 CCC ******, **** test 5 444 0 34 CCC ******, **** test 6 444 0 35 CCC ******, **** test 7 444 0 36 BBB *******, ***** test 1 555 0 37 BBB *******, ***** test 2 555 1 38 BBB *******, ***** test 3 555 0 39 BBB *******, ***** test 4 555 0 40 BBB *******, ***** test 5 555 1 41 BBB *******, ***** test 6 555 0 42 BBB *******, ***** test 7 555 0 Sheet2

 

[Eric W]

Try:

Sub TestTakers()
Dim MyData As Variant, OutData() As Variant, MyDic As Object
Dim i As Long, x As Variant

    MyData = Range("A2:E42").Value
    Set MyDic = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(MyData)
        If Not MyDic.exists(MyData(i, 1)) Then
            Set MyDic(MyData(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        MyDic(MyData(i, 1))(MyData(i, 4)) = 1
    Next i
    
    i = 1
    ReDim OutData(1 To MyDic.Count, 1 To 2)
    For Each x In MyDic
        OutData(i, 1) = x
        OutData(i, 2) = MyDic(x).Count
        i = i + 1
    Next x
    
    Range("I2").Resize(MyDic.Count, 2).Value = OutData
        
End Sub

Change the range in the first line to be the entire input range, and change the range in the last line to be where you want the results.

 

[Stephen_IV]

Hi Eric thanks for the reply,

Your code is giving me the result of

AAA	2
BBB	2
CCC	1

The result I am looking for is

AAA	1
BBB	2
CCC	0

for example the first school AAA id# 111 and start = all 0's does not get counted because the student did not start a test.

 

[Akuini]

@Stephen_IV
Assuming data is sorted by col ID, try this:

Sub Stephen_IV()
Dim flag As Boolean
Dim i As Long, j As Long
Dim va
Dim d As Object

va = Range("A1:E" & Cells(Rows.Count, "A").End(xlUp).Row)

        Set d = CreateObject("scripting.dictionary")
        d.CompareMode = vbTextCompare
 
For i = 2 To UBound(va, 1)
 j = i
    flag = False
    Do
        If flag = False Then
            If va(i, 5) <> 0 Then
               d(va(i, 1)) = d(va(i, 1)) + 1
                flag = True
            End If
        End If
            i = i + 1
        If i > UBound(va, 1) Then Exit Do
    Loop While va(i, 4) = va(i - 1, 4)
    i = i - 1

Next

'Put the result at G2
Range("g2").Resize(d.Count, 2) = Application.Transpose(Array(d.Keys, d.Items))
End Sub

 

[Stephen_IV]

Akuini,

That did the trick! Thank you and Eric W so much for the help.

 

[Eric W]

Just for the record, here's how to adjust mine to handle the 0 values in column E:

Sub TestTakers()
Dim MyData As Variant, OutData() As Variant, MyDic As Object
Dim i As Long, x As Variant

    MyData = Range("A2:E42").Value
    Set MyDic = CreateObject("Scripting.Dictionary")
    
    For i = 1 To UBound(MyData)
        If Not MyDic.exists(MyData(i, 1)) Then
            Set MyDic(MyData(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        If MyData(i, 5) > 0 Then MyDic(MyData(i, 1))(MyData(i, 4)) = 1
    Next i
    
    i = 1
    ReDim OutData(1 To MyDic.Count, 1 To 2)
    For Each x In MyDic
        OutData(i, 1) = x
        OutData(i, 2) = MyDic(x).Count
        i = i + 1
    Next x
    
    Range("I2").Resize(MyDic.Count, 2).Value = OutData
        
End Sub

Glad you got a solution.

 

[Stephen_IV]

Thanks Eric! I always appreciate any help I can get!