Option Explicit
Sub Arr_pg()
Application.ScreenUpdating = False
    Dim Arr() As String
    Dim WS As Worksheet
    Dim R As Range
    Dim N As Long, x As Long, y As Long
    Dim Formula As String
    Columns("A:B").Clear
    N = Range("H" & Rows.Count).End(xlUp).Row
    ReDim Arr(N + 5)
    
    x = 1
    Do While Cells(x, 8) <> ""
                Arr(x) = Cells(x, 8)
            x = x + 1
        Loop
    Set R = Range("A1").Resize(UBound(Arr) - LBound(Arr) + 1, 1)
        R = Application.Transpose(Arr)
        R.Sort key1:=R, order1:=xlAscending, MatchCase:=False
    y = Range("A" & Rows.Count).End(xlUp).Row
        For N = 1 To y
            Arr(N) = R(N, 1)
        Next N
    Columns("A").Select
    ActiveSheet.Range("$A$1:$A$" & y).RemoveDuplicates Columns:=1, Header:=xlNo
    
    y = Range("A" & Rows.Count).End(xlUp).Row
        For x = 1 To y
            Formula = "=CONTA.SE($H:$H;$A" & x & ")"
            Cells(x, 2).FormulaLocal = Formula
            Cells(x, 2).Copy
            Cells(x, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Next x
    Application.CutCopyMode = False
        Columns("A:B").Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("B1:B" & y), _
    SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:A" & y), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:B" & y)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A11:B" & y).ClearContents
    Range("A1").Select
End Sub

'---------------------------------------------------------------------------------------
' Procedure : uModa
' Author    : Scossa
' Date      : 17/03/2014
' Purpose   : restituisce una matrice bidimensionale con gli elementi ordinati
'             in base alla "moda"
'---------------------------------------------------------------------------------------
'
  Public Function uModa(ByVal rng As Range) As Variant
    Dim nCnt As Long
    Dim cDati As New Collection
    Dim cella As Range
    Dim vDato As Variant
    Dim aDati As Variant
    Dim j As Integer
    Dim vRet As Variant
    
    On Error Resume Next
    For Each cella In rng
      With cella
        nCnt = Application.WorksheetFunction.CountIf(rng, .Value)
        cDati.Add Array(.Value, nCnt), CStr(.Value)
      End With
    Next
    On Error GoTo 0
    
    ReDim aDati(1 To cDati.Count, 1 To 2)
    j = 0
    For Each vDato In cDati
      j = j + 1
      aDati(j, 1) = vDato(1)
      aDati(j, 2) = vDato(0)
    Next
    aDati = ArrayBiSort(aDati)
    uModa = aDati
  End Function

'---------------------------------------------------------------------------------------
' Function  : ArrayBiSort
' Author    : Scossa
' Date      : 17/03/2014
' Purpose   : ordina un array bidimensionale in base alla prima dimensione
'             (dal maggiore al minore)
'---------------------------------------------------------------------------------------
'
Private Function ArrayBiSort(ByVal ArrayIn As Variant)
  Dim vMaster As Variant
  Dim vSlave As Variant
  Dim i As Long
  Dim j As Long

  For i = LBound(ArrayIn) To UBound(ArrayIn)
    For j = i + 1 To UBound(ArrayIn)
      If ArrayIn(i, 1) < ArrayIn(j, 1) Then
        vMaster = ArrayIn(j, 1)
        vSlave = ArrayIn(j, 2)
        ArrayIn(j, 1) = ArrayIn(i, 1)
        ArrayIn(j, 2) = ArrayIn(i, 2)
        ArrayIn(i, 1) = vMaster
        ArrayIn(i, 2) = vSlave
      End If
    Next j
   Next i

  ArrayBiSort = ArrayIn

End Function