ich denke ich habe eine Lösung
11.02.2026 21:46:21
Christian
zumindest funktioniert sie in der geposteten Testdatei
'==============================
' Standardmodul
'==============================
Public Sub AktualisiereSpalteE(Optional ByVal ws As Worksheet)
On Error GoTo Cleanup
' Blatt setzen, falls nichts übergeben wurde
If ws Is Nothing Then Set ws = ThisWorkbook.Sheets("Tabelle1") ' - Namen anpassen
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Zelle As Range
Dim LetzteZeile As Long
' Letzte Zeile in Spalte E
LetzteZeile = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
' Spalte E: Datum formatieren, nur wenn Jahr >= 1900
For Each Zelle In ws.Range("E1:E" & LetzteZeile)
If IsDate(Zelle.Value) Then
If Year(Zelle.Value) >= 1900 Then
Zelle.Value = CDate(Zelle.Value)
Zelle.NumberFormat = "dd.mm.yyyy"
End If
End If
Next Zelle
' Ranking neu berechnen
BerechneCodesRanking ws
Cleanup:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If Err.Number > 0 Then
MsgBox "Fehler " & Err.Number & ": " & Err.Description, _
vbExclamation, "AktualisiereSpalteE"
End If
End Sub
Public Sub BerechneCodesRanking(ws As Worksheet)
Dim Eingabearray As Variant
Dim DatumArray() As Double
Dim Ausgabearray() As Variant
Dim RangDict As Object
Dim GesamtZeilen As Long
Dim i As Long, j As Long
Dim AnzahlGueltigerDaten As Long
Dim LetztesDatum As Double
' Daten aus Spalte E einlesen
GesamtZeilen = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
Eingabearray = ws.Range("E1:E" & GesamtZeilen).Value
' Nur gültige Datumswerte zählen
AnzahlGueltigerDaten = 0
For i = 1 To GesamtZeilen
If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) > "" Then
AnzahlGueltigerDaten = AnzahlGueltigerDaten + 1
End If
Next i
If AnzahlGueltigerDaten = 0 Then Exit Sub
' DatumArray dimensionieren
ReDim DatumArray(1 To AnzahlGueltigerDaten)
j = 1
For i = 1 To GesamtZeilen
If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) > "" Then
DatumArray(j) = DatumZuSortierwert(Eingabearray(i, 1))
j = j + 1
End If
Next i
' Absteigend sortieren
QuickSortDatum DatumArray, 1, AnzahlGueltigerDaten
' RangDictionary erstellen
Set RangDict = CreateObject("Scripting.Dictionary")
For i = 1 To AnzahlGueltigerDaten
If i = 1 Or DatumArray(i) > LetztesDatum Then
RangDict(CStr(DatumArray(i))) = i
End If
LetztesDatum = DatumArray(i)
Next i
' Ausgabe vorbereiten
ReDim Ausgabearray(1 To GesamtZeilen, 1 To 1)
For i = 1 To GesamtZeilen
If IsDate(Eingabearray(i, 1)) Or Trim(Eingabearray(i, 1)) > "" Then
Ausgabearray(i, 1) = WorksheetFunction.RoundUp( _
RangDict(CStr(DatumZuSortierwert(Eingabearray(i, 1)))) / AnzahlGueltigerDaten, 2)
End If
Next i
' Ergebnisse in Spalte F schreiben
ws.Range("F1").Resize(GesamtZeilen, 1).Value = Ausgabearray
ws.Range("F1").Resize(GesamtZeilen, 1).NumberFormat = "0%"
End Sub
Private Function DatumZuSortierwert(ByVal v As Variant) As Double
Dim Teile() As String
Dim Tag As Long, Monat As Long, Jahr As Long
' Wenn Excel es als Datum erkennt
If IsDate(v) Then
Jahr = Year(v)
Monat = Month(v)
Tag = Day(v)
DatumZuSortierwert = Jahr * 10000# + Monat * 100# + Tag
Exit Function
End If
' Wenn Text "dd.mm.yyyy"
If InStr(v, ".") > 0 Then
Teile = Split(v, ".")
If UBound(Teile) = 2 Then
Tag = Val(Teile(0))
Monat = Val(Teile(1))
Jahr = Val(Teile(2))
DatumZuSortierwert = Jahr * 10000# + Monat * 100# + Tag
Exit Function
End If
End If
' Sonst 0 zurückgeben
DatumZuSortierwert = 0
End Function
Private Sub QuickSortDatum(ByRef arr() As Double, ByVal IndexUnten As Long, ByVal IndexOben As Long)
Dim PivotWert As Double
Dim TempWert As Double
Dim Links As Long
Dim Rechts As Long
Links = IndexUnten
Rechts = IndexOben
PivotWert = arr((IndexUnten + IndexOben) \ 2)
Do While Links = Rechts
Do While arr(Links) > PivotWert
Links = Links + 1
Loop
Do While arr(Rechts) PivotWert
Rechts = Rechts - 1
Loop
If Links = Rechts Then
TempWert = arr(Links)
arr(Links) = arr(Rechts)
arr(Rechts) = TempWert
Links = Links + 1
Rechts = Rechts - 1
End If
Loop
If IndexUnten Rechts Then QuickSortDatum arr, IndexUnten, Rechts
If Links IndexOben Then QuickSortDatum arr, Links, IndexOben
End Sub
Gruß
Christian