Option Explicit
#Const ByAlphabet = True
Public Sub main()
Dim sText As String, sChar As String * 1
Dim i As Long
Dim key As Variant
Dim oDict As Object
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = vbTextCompare
#If ByAlphabet Then
sText = "абвгдеёжзийклмнопрстуфхцчшщьыъэюя"
For i = 1 To Len(sText)
oDict.Add Mid$(sText, i, 1), 0&
Next
#End If
sText = ThisWorkbook.Sheets(1).[A1]
For i = 1 To Len(sText)
sChar = Mid$(sText, i, 1)
If oDict.Exists(sChar) Then
oDict(sChar) = oDict(sChar) + 1
Else
#If Not ByAlphabet Then
oDict.Add sChar, 1&
#End If
End If
Next
With ThisWorkbook.Sheets(2)
.Cells.ClearContents
i = 0
For Each key In oDict.keys
i = i + 1
.Cells(i, 1) = UCase(key)
.Cells(i, 2) = oDict(key)
Next
End With
Set oDict = Nothing
End Sub