Hi Timo,

probiere mal so:

Sub ErmitteleHaeufigsteZahl()
    Dim ws As Worksheet
    Dim rng As Range, cell As Range
    Dim dict As Object
    Dim maxCount As Integer
    Dim mostFrequent As Double
    Dim key As Variant
    Dim roundedValue As Double
    
    Set ws = ThisWorkbook.Sheets(1) ' Anpassen, falls anderes Sheet genutzt wird
    Set rng = ws.Range("P8:P23")
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Werte einlesen und Häufigkeit ermitteln
    For Each cell In rng
        If IsNumeric(cell.Value) And cell.Value <> "" Then
            key = Round(cell.Value, 2) ' Auf 2 Nachkommastellen runden
            If dict.exists(key) Then
                dict(key) = dict(key) + 1
            Else
                dict.Add key, 1
            End If
        End If
    Next cell
    
    ' Häufigste Zahl bestimmen
    maxCount = 0
    mostFrequent = 0
    
    For Each key In dict.keys
        If dict(key) > maxCount Then
            maxCount = dict(key)
            mostFrequent = key
        ElseIf dict(key) = maxCount Then
            ' Falls Gleichstand, kleineren Wert nehmen
            If key < mostFrequent Then
                mostFrequent = key
            End If
        End If
    Next key
    
    ' Falls keine Zahl gefunden wurde, abbrechen
    If maxCount = 0 Then
        ws.Range("A1").Value = ""
        Exit Sub
    End If
    
    ' Rundung auf 0,5er Schritte
    roundedValue = Round(mostFrequent * 2, 0) / 2
    
    ' Ergebnis in A1 schreiben
    ws.Range("A1").Value = roundedValue
    
    ' Objekte freigeben
    Set dict = Nothing
    Set rng = Nothing
    Set ws = Nothing
End Sub