AUSFÜHRLICH UND ZUM MITLESEN

Option Explicit
'"Scripting.Dictionary"
'ggf. VERWEIS SETZEN

Sub Zahlenwenn()
Const Zahlenspalte As Variant = "B"
Const Ergebnisspalte As Variant = "D"

Dim varArray As Variant
Dim objMyDic As Object
Dim V        As Variant

Dim rngZahlen As Range
Dim rngA As Range, rngC As Range
Dim arrV() As Variant
'
   Set objMyDic = CreateObject("Scripting.Dictionary")
'
   With Columns(Zahlenspalte)
      Set rngZahlen = .ColumnDifferences(.Cells(.Cells.Count))
      For Each rngA In rngZahlen
         For Each rngC In rngA
            If IsNumeric(rngC.Value) Then
               V = rngC.Value
               objMyDic(V) = V
            End If
         Next rngC
      Next rngA
   End With
   
   arrV = objMyDic.Items()
   
   Columns(Ergebnisspalte).Offset(, 1).ClearContents
   With Columns(Ergebnisspalte)
      .ClearContents
      Set rngC = .Cells(1)
      Set rngC = rngC.Resize(UBound(arrV) + 1, 1)
      rngC.Value = Application.Transpose(arrV)
      Set rngA = .Cells(1)
      Set rngA = Range(rngA, rngA.End(xlDown))
      For Each rngC In rngA
         rngC.Offset(, 1).Value = WorksheetFunction.CountIfs(Columns(Zahlenspalte), rngC.Value)
      Next rngC
   End With

   Set rngA = rngA.Resize(, 2)
   With ActiveSheet.Sort
      With .SortFields
         .Clear
         .Add Key:=Range(rngA.Columns(1).Address), _
            SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
      End With
      .SetRange Range(rngA.Address)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
      With .SortFields
         .Clear
         .Add Key:=Range(rngA.Columns(2).Address), _
            SortOn:=xlSortOnValues, _
            Order:=xlDescending, DataOption:=xlSortNormal
      End With
      .SetRange Range(rngA.Address)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
   End With


End Sub