Sub conta2() ' nel foglio 1
    Dim myDir As String, fn As String, dic As Object
    Dim a As Variant, e As Variant
    Set dic = CreateObject("Scripting.Dictionary")
    
    dic.CompareMode = TextCompare
    With Sheets(1)
        a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
    End With
    If IsArray(a) Then
      For Each e In a
        If e <> "" Then                 
          If Not dic.Exists(e) Then       'se la chiave e non esiste già
            dic.Add Key:=e, Item:=0         'aggiungi un elemento a Dic con key e ed item 0
          End If
          dic.Item(e) = dic.Item(e) + 1   'se la chiave esiste assegna all'item con chiave e un nuovo valore
        End If
      Next
    End If
    Sheets(1).Cells(3).Resize(dic.Count, 2).Value = _
    Application.Transpose(Array(dic.keys, dic.Items))
    Set dic = Nothing
End Sub

Sub Conta_Library()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' ATTENZIONE RICHIEDE L'ATTIVAZIONE DELLA LIBRERIA MICROSOFT SCRIPTING RUNTIME '''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Per l'attivazione andare su "Strumenti", "Riferimenti", cercare e spuntare il nome ''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim oDic As Dictionary
  Dim vDati As Variant, vEl As Variant
  Set oDic = New Dictionary
  
  With Worksheets(1)
    vDati = .Range("a1", .Range("a" & .Rows.Count).End(xlUp)).Value
  End With
  
  With oDic
  
    .CompareMode = TextCompare 'h t t p :/ /ms dn. mic rosoft.com/ en-us /library/office/gg278481(v=office.15).aspx
   
    For Each vEl In vDati
      If vEl <> "" Then
        If Not .Exists(vEl) Then
          .Add vEl, 0
        End If
        .Item(vEl) = .Item(vEl) + 1
      End If
    Next vEl
    
    Worksheets(1).Cells(1, 3).Resize(.Count, 1) = Application.Transpose(.Keys)
    Worksheets(1).Cells(1, 4).Resize(.Count, 1) = Application.Transpose(.Items)
    
  End With
  Set oDic = Nothing
End Sub

          dic.Item(e) = dic.Item(e) + 1