AW: 5 besten Ergebnisse sollen markiert werden
ChrisL
Hi Andreas
Viel Spass damit...
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zeile As Long, iSpalte As Byte
Dim Arr(), iArr As Integer
Dim PositionMax As Integer
If Target.Column >= 3 And Target.Column <= 16 And _
Target.Row >= 2 And Target.Row <= 5 Then
Zeile = Target.Row
For iSpalte = 3 To 16
If Cells(Zeile, iSpalte) = "" Then Exit For
ReDim Preserve Arr(0 To iSpalte - 3)
Arr(UBound(Arr)) = Cells(Zeile, iSpalte)
Next iSpalte
Range(Cells(Zeile, 19), Cells(Zeile, 23)).ClearContents
Range(Cells(Zeile, 3), Cells(Zeile, 16)).Font.Bold = False
iSpalte = 19
Do Until iSpalte > 23
For iArr = UBound(Arr) To 0 Step -1
If Arr(iArr) = WorksheetFunction.Max(Arr) Then
PositionMax = iArr
Exit For
End If
Next iArr
Cells(Zeile, PositionMax + 3).Font.Bold = True
Cells(Zeile, iSpalte) = Arr(PositionMax)
Arr(PositionMax) = 0
iSpalte = iSpalte + 1
If iSpalte > 23 Then Exit Sub
Loop
End If
End Sub
Gruss
Chris
https://www.herber.de/bbs/user/4663.xls