VBA to replace Countifs

Hello,

I have a spreadsheet that has 11 columns and almost 850,000 row. Each day should have 48 readings, but some have more, due to duplicates, others have less.
When I use Countifs, it is very slow and constantly crashes. I was wondering if anyone had any suggestions on VBA code I could use?
I have created a small sample sheet. It has less columns and rows, but should give you an idea of what I'm looking for.

If this runs fine, replace Sheet.Add with Sheets("YourSheeName")

Sub test()
    Dim a, e, i As Long, ii As Long
    Dim dic As Object, AL As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Set AL = CreateObject("System.Collections.ArrayList")
    a = Sheets("eco").Cells(1).CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 1)) Then
            Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        If Not AL.contains(a(i, 3)) Then AL.Add a(i, 3)
        dic(a(i, 1))(a(i, 3)) = dic(a(i, 1))(a(i, 3)) + 1
    Next
    ReDim a(1 To dic.Count + 1, 1 To AL.Count + 1): AL.Sort
    For ii = 0 To AL.Count - 1
        a(1, ii + 2) = AL(ii)
    Next
    i = 1
    For Each e In dic
        i = i + 1
        a(i, 1) = e
        For ii = 2 To UBound(a, 2)
            a(i, ii) = dic(e)(a(1, ii))
            If a(i, ii) = "" Then a(i, ii) = 0
        Next
    Next
    With Sheets.Add.Cells(1).Resize(UBound(a, 1), UBound(a, 2))
        .Value = a: .Cells(1).Value = "Site"
        Union(.Columns(1), .Rows(1)).Font.Bold = True
        .Sort .Cells(1), , , , , , , xlYes
        .HorizontalAlignment = xlCenter
        .Columns.AutoFit
    End With
End Sub

Thank you, this works perfectly

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