Посчитать, сколько раз в строке встречается каждая цифра

Sub main()
Dim S$
Dim a%(0 To 9)
Dim I%
S = InputBox("Введите строку")
For I = 1 To Len(S)
  If IsNumeric(Mid$(S, I, 1)) Then a(Mid$(S, I, 1)) = a(Mid$(S, I, 1)) + 1
Next I
S = "В строке " & S
For I = 0 To 9
  S = S & vbLf & I & " - " & a(I) & " раз"
Next I
MsgBox S
End Sub

Sub lebr()
Dim s$, d$, i&, j&, k&
s = InputBox("Введите строку", , "https://www.cyberforum.ru/vba/thread425497.html#post2372642")
On Error Resume Next
With New Collection
    For i = 1 To Len(s)
        d = Mid$(s, i, 1)
        If IsNumeric(d) Then
            If .Count > 0 Then .Add Array(1, d), d, before:=1 Else .Add Array(1, d), d
            If Err Then
                Err.Clear
                j = .Item(d)(0) + 1
                .Remove d
                For k = 1 To .Count
                    If j <= .Item(k)(0) Then .Add Array(j, d), d, before:=k: Exit For
                Next
                If k > .Count Then .Add Array(j, d), d
            End If
        End If
    Next
    d = ""
    For i = 1 To .Count
        d = d & vbLf & .Item(i)(1) & vbTab & .Item(i)(0)
    Next
End With
MsgBox "В строке" & vbLf & s & vbLf & "Цифры" & vbTab & "Повторы" & d
End Sub

Sub lebr1()
Dim s$, d$, i&, j&, k&, m&
s = InputBox("Введите строку", , "https://www.cyberforum.ru/vba/thread425497.html#post2372642")
i = Len(s)
With New Collection
    For j = 0 To 9
        k = i - Len(Replace$(s, j, ""))
        If k Then
            For m = 1 To .Count
                If k <= .Item(m)(0) Then .Add Array(k, j), CStr(j), before:=m: Exit For
            Next
            If m > .Count Then .Add Array(k, j), CStr(j)
        End If
    Next
    For i = 1 To .Count
        d = d & vbLf & .Item(i)(1) & vbTab & .Item(i)(0)
    Next
End With
MsgBox "В строке" & vbLf & s & vbLf & "Цифры" & vbTab & "Повторы" & d
End Sub

Call QuickSort(a)

Option Explicit
 
Sub test()
Dim a(99999) As Single, t As Single
Dim I As Long             'Хоар         Aeliot
For I = 0 To UBound(a)    'QuickSort    QuickSortS
  a(I) = Rnd              '0,46875      0,546875
  'a(I) = I                '0,203125     468,3281
  'a(I) = UBound(a) - I    '0,234375    ~700 - запускать не стал, проинтерполировал
Next I
t = Timer
'QuickSortS a  'Aeliot
QuickSort a, 0, UBound(a)  'Хоар
Debug.Print Timer - t
End Sub
 
'Хоар
Sub QuickSort(a, ByVal L As Long, ByVal U As Long)
Dim I As Long, J As Long, x As Single, y As Single
I = L: J = U: x = a((L + U) \ 2)
Do
  While a(I) < x: I = I + 1: Wend: While x < a(J): J = J - 1: Wend 'по возрастанию
'  While A(I) > X: I = I + 1: Wend: While X > A(J): J = J - 1: Wend 'по убыванию
  If I <= J Then
    y = a(I): a(I) = a(J): a(J) = y:    I = I + 1: J = J - 1
  End If
Loop Until I > J
If L < J Then QuickSort a, L, J
If I < U Then QuickSort a, I, U
End Sub
 
'Aeliot
Sub QuickSortS(arr, Optional numEls As Variant, Optional descending As Boolean)
    Dim value As Single, temp As Single
    Dim sP As Integer
    Dim leftStk(32) As Long, rightStk(32) As Long
    Dim leftNdx As Long, rightNdx As Long
    Dim I As Long, J As Long
    
    ' account for optional arguments
    If IsMissing(numEls) Then numEls = UBound(arr)
    ' init pointers
    leftNdx = LBound(arr)
    rightNdx = numEls
    ' init stack
    Dim asd As String
    asd = CStr(arr(1))
    sP = 1
    leftStk(sP) = leftNdx
    rightStk(sP) = rightNdx
    
    Do
        If rightNdx > leftNdx Then
            value = arr(rightNdx)
            I = leftNdx - 1
            J = rightNdx
            ' find the pivot item
            If descending Then
                Do
                    Do: I = I + 1: Loop Until arr(I) <= value
                    Do: J = J - 1: Loop Until J = leftNdx Or arr(J) >= value
                    temp = arr(I)
                    arr(I) = arr(J)
                    arr(J) = temp
                Loop Until J <= I
            Else
                Do
                    Do: I = I + 1: Loop Until arr(I) >= value
                    Do: J = J - 1: Loop Until J = leftNdx Or arr(J) <= value
                    temp = arr(I)
                    arr(I) = arr(J)
                    arr(J) = temp
                Loop Until J <= I
            End If
            ' swap found items
            temp = arr(J)
            arr(J) = arr(I)
            arr(I) = arr(rightNdx)
            arr(rightNdx) = temp
            ' push on the stack the pair of pointers that differ most
            sP = sP + 1
            If (I - leftNdx) > (rightNdx - I) Then
                leftStk(sP) = leftNdx
                rightStk(sP) = I - 1
                leftNdx = I + 1
            Else
                leftStk(sP) = I + 1
                rightStk(sP) = rightNdx
                rightNdx = I - 1
            End If
        Else
            ' pop a new pair of pointers off the stacks
            leftNdx = leftStk(sP)
            rightNdx = rightStk(sP)
            sP = sP - 1
            If sP = 0 Then Exit Do
        End If
    Loop
End Sub