Drei Farbspielereien

[d'r Bastler]

Moin,

hier drei Farbspielereien als Spickzettel für die Umgehung von Bedingten Formatierungen per Formel. Die Codes gehören in eine Arbeitsmappe.

• Zellen nach Wert einfärben (falls numerisch)

Code: Alles auswählen

Option Explicit

Sub AllesSoSchoenBuntHier()
Dim rng As Range

Cells.ClearFormats

For Each rng In ActiveSheet.UsedRange
   If IsNumeric(rng.Value) Then
        Select Case rng.Value
            Case 1
                rng.Interior.Color = RGB(255, 0, 0)
            Case 2
                rng.Interior.Colorindex = 27
            Case 3
                rng.Interior.Color = vbBlue
        End Select
    End If
Next
End Sub

Der Code zeigt alle drei Syntax-Varianten per VBA Farben abzurufen.

• Looks like Tabellierpapier

Code: Alles auswählen

Sub Tabellierpapier()

Dim rng As Range, r As Integer, c As Integer

Cells.ClearFormats

c = UsedRange.Columns.Count
UsedRange.Cells.Interior.ColorIndex = 19

For Each rng In ActiveSheet.UsedRange
    r = rng.Row
    If r Mod 2 = 0 Then
        Range(Cells(r, 1), Cells(r, c)).Interior.ColorIndex = 35
    End If
Next
End Sub

• vbFarben und Farbindex zu RGB

Code: Alles auswählen

Sub vbColors()
Dim i As Integer, j As Integer, iDX As Integer, c As Integer
Dim R As Long, G As Long, B As Long, iVal As Long
Dim aVB 'Array

Cells.Clear

aVB = Array("vbBlack", "vbWhite", "vbRed", "vbGreen", "vbBlue", "vbYellow", "vbMagenta", "vbCyan")
c = 1: iDX = 1

For i = 1 To 4
    For j = 1 To 14
        Cells(j, c) = iDX
        Cells(j, c + 1).Interior.ColorIndex = iDX
        If iDX < 9 Then
            Cells(j, c + 2) = "  " & aVB(iDX - 1)
        Else
            iVal = Cells(j, c + 1).Interior.Color
                R = iVal Mod 256
                iVal = (iVal - R) / 256
                G = iVal Mod 256
                iVal = (iVal - G) / 256
                B = iVal Mod 256
            Cells(j, c + 2) = "  RGB(" & R & "," & G & "," & B & ")"
        End If
        iDX = iDX + 1
    Next j
    c = c + 3
Next i

For i = 1 To 10 Step 3
    Columns(i).ColumnWidth = 5
    Columns(i).HorizontalAlignment = xlCenter
Next i
For i = 2 To 12 Step 3
    Columns(i).ColumnWidth = 10
Next i
For i = 3 To 12 Step 3
    Columns(i).ColumnWidth = 20
Next i
End Sub

Wenn ich noch einen Trick (er)finde, wie man den XL-Indexfarben die richtigen HTML-Farbnamen zuordnen kann. gibt es einen passenden Nachtrag.


Schöne Grüße

[d'r Bastler]

So - und nun noch Farbspielerei Nr. 4, die offenbart, dass die in XL über vbNamen oder Colorindex ansprechbaren vermeintlichen 56 Farben tatsächlich nur 46 sind ... Ein Vergleich der RGB-Werte bringt's an den Tag.

Code: Alles auswählen

Sub SortedRGB()
Dim i As Integer, iVal As Long, iDub As Integer, iRow As Integer
Dim R As Integer, G As Integer, B As Integer, sMSG As String
Dim aCols 'Array

Cells.Clear

aCols = Array("5", "10", "10", "20", "5")

For i = 1 To 56
    Cells(i, 1) = i
    Cells(i, 2).Interior.ColorIndex = (i)
    Cells(i, 3) = Cells(i, 2).Interior.Color
    iVal = Cells(i, 2).Interior.Color
            R = iVal Mod 256
            iVal = (iVal - R) / 256
            G = iVal Mod 256
            iVal = (iVal - G) / 256
            B = iVal Mod 256
    Cells(i, 4) = "  RGB(" & R & "," & G & "," & B & ")"
Next i


    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add2 Key:=Range( _
        "C1:C56"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Tabelle1").Sort
        .SetRange Range("A1:D56")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
sMSG = "Colorindex " & vbNewLine
For i = 1 To 56
    If Cells(i, 3) = Cells(i + 1, 3) Then
        iDub = iDub + 1
        Cells(i, 5) = "<<<"
        sMSG = sMSG & Cells(i, 1) & " = " & Cells(i + 1, 1) & " in Zeile " & i & " & " & i + 1 & vbNewLine
    End If
Next i
MsgBox sMSG, , iDub & " Dubletten gefunden!"

For i = 0 To UBound(aCols)
    Columns(i + 1).ColumnWidth = aCols(i)
Next i

Cells(1, 1).Activate

End Sub

Grüße