Extraer valores únicos, pegar y contar repeticiones excel vba

Te anexo la macro.

No es necesario ordenar los datos.

Tampoco es necesario un progress bar

Hice la prueba con 33,000 registros y la respuesta es inmediata.

Sub Contar_Areas()
'
'Por.Dante Amor
'
    '
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("Hoja2")
    h2.Cells.Clear
    u1 = h1.Range("I" & Rows.Count).End(xlUp).Row
    h1.Range("I4:I" & u1).Copy h2.Range("A1")
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    With h2.Range("B2:B" & u2)
        .FormulaR1C1 = "=COUNTIF(hoja1!C[7],Hoja2!RC[-1])"
        .Value = .Value
    End With
    Application.ScreenUpdating = True
    MsgBox "fin"
End Sub

sal u dos

Hola Dante gracias por tu apoyo, tal-vez falte un pequeño ajuste me sale valor cero 

¿Modificaste la macro?

Según tu imagen, supongo que en la hoja1, en la celda I4, tienes el título "Área" y tus datos empiezan a partir de la celda I5.

Si no es así, entonces dime cómo están tus datos en la hoja1 para ajustar la macro.

Dante, solo cambié el el nombre de la hoja y mis datos empieza I4.

también te comento que algunas ÁREAS están en blanco,  poco a poco voy corrigiendo

Sub Contar_Areas()
'Por.Dante Amor
'
    '
    Application.ScreenUpdating = False
    Set h1 = Sheets("BIBLIOTECA")
    Set h2 = Sheets("Hoja2")
    h2.Cells.Clear
    u1 = h1.Range("I" & Rows.Count).End(xlUp).Row
    h1.Range("I5:I" & u1).Copy h2.Range("A1")
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    With h2.Range("B2:B" & u2)
        .FormulaR1C1 = "=COUNTIF(hoja1!C[7],Hoja2!RC[-1])"
        .Value = .Value
    End With
    Application.ScreenUpdating = True
    MsgBox "fin"
End Sub

Dante, te envié el archivo para que les un vistazo saludos!

Se que tu pregunta está dirigida directamente a Dante, pero te propongo la siguiente solución...:

Sub OrdenarExtraerContar()
    Set c = Range("i" & Rows.Count).End(xlUp)
    c.Select
    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add Key:=c, _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Hoja1").Sort
        .SetRange Range("A2:i" & c.Row)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Hoja1").Range("i2:i" & c.Row).Copy
    ActiveWorkbook.Worksheets("Hoja2").Select
    ActiveSheet.Range("a3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Set c = Range("a" & Rows.Count).End(xlUp)
    ActiveSheet.Range("$A$3:$A$" & c.Row).RemoveDuplicates Columns:=1, Header:=xlNo
    Columns("A:A").EntireColumn.AutoFit
    Set c = Range("a" & Rows.Count).End(xlUp)
    Range("B3:B" & c.Row).Select
    Selection.FormulaR1C1 = "=COUNTIF(Hoja1!C9,RC[-1])"
End Sub

me error se requiere un objeto 

buen día ya lo corregí, pero sale con valor 0