AW: Top 10; KKleinste mit Zellfarbe, Zellformat
ChrisL
Hi Joezett
Sub KKleinstSpezial()
Dim Arr(1 To 37)
Dim Zelle As Range
Dim iArr As Byte, iRank As Byte
Dim iZeile As Byte, iSpalte As Byte
'Farbe und Formatierung zurücksetzen
Range("E3:AR14").Font.Bold = False
Range("E3:AR14").Font.ColorIndex = 0
Range("E17:AR29").Font.Bold = False
Range("E17:AR29").Font.ColorIndex = 0
Range("E32:AR43").Font.Bold = False
Range("E32:AR43").Font.ColorIndex = 0
For iSpalte = 5 To 44
'Werte in Array einlesen
iArr = 1
For iZeile = 3 To 14
Arr(iArr) = Cells(iZeile, iSpalte)
iArr = iArr + 1
Next iZeile
For iZeile = 17 To 29
Arr(iArr) = Cells(iZeile, iSpalte)
iArr = iArr + 1
Next iZeile
For iZeile = 32 To 43
Arr(iArr) = Cells(iZeile, iSpalte)
iArr = iArr + 1
Next iZeile
'10 kleinsten Werte ermitteln
For iRank = 1 To 10
If WorksheetFunction.Count(Arr) > 10 Then
For Each Zelle In Range(Cells(3, iSpalte), Cells(14, iSpalte))
If Zelle = WorksheetFunction.Small(Arr, iRank) Then
Zelle.Font.Bold = True
Zelle.Font.ColorIndex = 3
End If
Next Zelle
For Each Zelle In Range(Cells(17, iSpalte), Cells(29, iSpalte))
If Zelle = WorksheetFunction.Small(Arr, iRank) Then
Zelle.Font.Bold = True
Zelle.Font.ColorIndex = 3
End If
Next Zelle
For Each Zelle In Range(Cells(32, iSpalte), Cells(43, iSpalte))
If Zelle = WorksheetFunction.Small(Arr, iRank) Then
Zelle.Font.Bold = True
Zelle.Font.ColorIndex = 3
End If
Next Zelle
End If
Next iRank
Next iSpalte
End Sub
Gruss
Chris