Beginnend in Zelle B6 stehen nach unten Werte.
Die 4 größten Werte sollen nun mit unterschiedlichen Füllfarben hinterlegt werden.
Wie kann man diese Aufgabe mit VBA umsetzen?
Gruß
Christina Verena
Sub Christina()
Dim rng As Range, rngAll As Range
Dim vntRet As Variant
Set rngAll = Range("B6:B" & Application.Max(6, Cells(Rows.Count, 2).End(xlUp).Row))
rngAll.Interior.ColorIndex = xlNone
On Error Resume Next
For Each rng In rngAll
If IsNumeric(rng) Then
If rng = Application.Large(rngAll, 1) Then rng.Interior.ColorIndex = 4
If rng = Application.Large(rngAll, 2) Then rng.Interior.ColorIndex = 5
If rng = Application.Large(rngAll, 3) Then rng.Interior.ColorIndex = 6
If rng = Application.Large(rngAll, 4) Then rng.Interior.ColorIndex = 3
End If
Next
On Error GoTo 0
Set rngAll = Nothing
End Sub
Sub Bedingte_Formatierung()
Dim z As Integer
For z = 6 To 14
If Cells(z, 2) = Application.Large(Range("B6:B14"), z - 5) Then Cells(z, 2).Interior.ColorIndex _
= 5
If Cells(z, 2) = Application.Large(Range("B6:B14"), z - 4) Then Cells(z, 2).Interior.ColorIndex _
= 8
If Cells(z, 2) = Application.Large(Range("B6:B14"), z - 3) Then Cells(z, 2).Interior.ColorIndex _
= 11
If Cells(z, 2) = Application.Large(Range("B6:B14"), z - 2) Then Cells(z, 2).Interior.ColorIndex _
= 14
Next z
End Sub
Kannst Du mir mitteilen, weshalb Laufzeitfehler 13 Typen unverträglich erscheint?
Sub Christina()
Dim rng As Range, rngAll As Range
Dim dblValues(3) As Double, lngIndex As Long, lngC As Long
Set rngAll = Range("B6:B" & Application.Max(6, Cells(Rows.Count, 2).End(xlUp).Row))
rngAll.Interior.ColorIndex = xlNone
On Error Resume Next
Do
lngC = lngC + 1
If IsError(Application.Match(Application.Large(rngAll, lngC), dblValues, 0)) Then
dblValues(lngIndex) = Application.Large(rngAll, lngC)
lngIndex = lngIndex + 1
End If
Loop While lngIndex < 4
For Each rng In rngAll
Select Case rng
Case dblValues(0): rng.Interior.ColorIndex = 4
Case dblValues(1): rng.Interior.ColorIndex = 5
Case dblValues(2): rng.Interior.ColorIndex = 6
Case dblValues(3): rng.Interior.ColorIndex = 3
End Select
Next
On Error GoTo 0
Set rngAll = Nothing
End Sub