Option Explicit
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