=СЧЁТЕСЛИ($A$1:$A$37;A1)

Option Explicit

Sub otbor()

       Dim a(), oDict As Object, i As Long, Temp As String

       a = Sheets(1).Range("A1:A" & Sheets(1).Range("A" & Rows.Count).End(xlUp).Row).Value
       Set oDict = CreateObject("Scripting.Dictionary")
       For i = 1 To UBound(a)
           Temp = Trim(a(i, 1))
           If Not oDict.Exists(Temp) Then
               oDict.Add Temp, CStr(1)
           Else
               'MsgBox "Double!": Exit Sub
               oDict.Item(Temp) = CStr(--oDict.Item(Temp) + 1)
           End If
       Next

       With ThisWorkbook.Worksheets(1)
           .Range("C1").Resize(oDict.Count) = Application.Transpose(oDict.keys)
           .Range("D1").Resize(oDict.Count) = Application.Transpose(oDict.items)
       End With

MsgBox "Not Unique in " & UBound(a) - oDict.Count & " Cells."

End Sub