VBA Excel - Countif - przyspieszenie

witam,
napisałem makro, które filtruje plik z danymi i usuwa rekordy z danymi które mnie nie interesują.
Jednym z etapów jest usunięcie tych rekordów, gdzie ID występuje mniej niż 4 razy. Zrobiłem to poprzez CountIf, wpisując w dodatkowej kolumnie liczbę wystąpień, a następnie odfiltrowałem i usunąłem. Przy pliku ze 140 tys rekordów makro działa ok 8 minut, przy drugim pliku z ponad milionem rekordów czas znacznie się wydłuża.

czy jest jakiś sposób lub zamiennik na funkcję countiff?

mam

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

a tutaj fragment kodu z countif

Dim wb_this As Excel.Workbook
Set wb_this = ThisWorkbook

 For j = 2 To ost_crm
    zremed = Application.VLookup(wb_this.Sheets("roboczy").Range("A" & j), wb_zrem.Sheets(1).Range("A:A"), 1, False)
    ile_wystapien = Application.WorksheetFunction.CountIf(wb_this.Sheets("roboczy").Range("A:A"), wb_this.Sheets("roboczy").Range("A" & j))
    wb_this.Sheets("roboczy").Range("I" & j).Value = ile_wystapien
    If IsError(zremed) Then
      wb_this.Sheets("roboczy").Range("H" & j).Value = "brak"
    Else
      wb_this.Sheets("roboczy").Range("H" & j).Value = zremed
    End If
    Next j

Wszystkie funkcje tablicowe w Excelu działają... tak sobie. Rozwiązaniem na to jest wstawienie CountIf, a następnie skopiowanie tego i wstawienie jako wartości...
Jeszcze inne rozwiązanie. Jeśli możesz, to posortuj wg kolumny A i sprawdzaj, czy A2=A3, A3=A4... to znacznie szybsze niż countif.

Poniżej propozycja znalezienia ilości wystąpień danej wartości w kolumnie i wypisaniem wartość, ilość wystąpień. Założenie: rekordy posortowane ASC.
Czasy, które uzyskałem

Czas ok 2 min
300 k wszystkich rekordów
100 k unikalnych rekordów

Czas 7:51 min; 7:19 min; 6:55 min
1 048 574 wszystkich rekordów
349 525 unikalnych rekordów

Option Explicit

Sub CountIf()
Dim i As Long
Dim LRow As Long
Dim sID_current As String
Dim sID_previous As String
Dim tID_unique() As String
Dim tID_unique_count() As Long
Dim nIndex As Long
Dim t As Date

Application.ScreenUpdating = False

t = Now()

With Sheets("Arkusz1")
    LRow = .Cells.SpecialCells(xlCellTypeLastCell).Row - 1
End With

ReDim Preserve tID_unique(LRow)
ReDim Preserve tID_unique_count(LRow)

Range("A2").Select
nIndex = 0

For i = 1 To LRow
    sID_previous = sID_current
    sID_current = ActiveCell.Value
    
    If sID_current = sID_previous Then
        tID_unique_count(nIndex) = tID_unique_count(nIndex) + 1
    Else
        nIndex = nIndex + 1
        tID_unique(nIndex) = sID_current
        tID_unique_count(nIndex) = 1
    End If
    
    ActiveCell.Offset(1, 0).Select
Next

ReDim Preserve tID_unique(nIndex)
ReDim Preserve tID_unique_count(nIndex)

Range("C2").Select
For i = 1 To UBound(tID_unique)
    ActiveCell.Value = tID_unique(i)
    ActiveCell.Offset(0, 1).Value = tID_unique_count(i)
    ActiveCell.Offset(1, 0).Select
Next

Application.ScreenUpdating = True
MsgBox "Koniec: " & Format(Now() - t, "hh:mm:ss")

End Sub