Option Explicit
Sub TabelleFarbindexe_mitRGBFarbenWerten()
Const c_MAX_ANZ_SPALTEN = 4
Dim wb As Workbook, ws As Worksheet
Dim l_spalte As Long, l_zeile As Long, i As Long
Dim rot As Long, gruen As Long, blau As Long
Dim farbe As Long
->neue Mappe anlegen
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
l_zeile = 0
l_spalte = c_MAX_ANZ_SPALTEN
For i = 1 To 56
l_spalte = l_spalte + 1
->c_MAX_ANZ_SPALTEN überschritten ?
If l_spalte > c_MAX_ANZ_SPALTEN Then
->nächste Zeile
l_spalte = 1
l_zeile = l_zeile + 1
End If
ws.Cells(l_zeile, l_spalte).Interior.ColorIndex = i
farbe = ws.Cells(l_zeile, l_spalte).Interior.Color
rot = farbe \ (2 ^ 16)
farbe = farbe - ((2 ^ 16) * rot)
gruen = farbe \ (2 ^ 8)
blau = farbe - ((2 ^ 8) * gruen)
ws.Cells(l_zeile, l_spalte).NumberFormat = @
ws.Cells(l_zeile, l_spalte).Value = _
Colorindex: = & i & RGB( & rot & , & gruen & , & blau & )
If gruen < 60 Then
ws.Cells(l_zeile, l_spalte).Font.Color = RGB(255, 255, 255)
End If
Next
For l_spalte = 1 To c_MAX_ANZ_SPALTEN: ws.Columns(l_spalte).AutoFit: Next
Aufraeumen:
Set ws = Nothing: Set wb = Nothing
End Sub
'************************************************
Sub SelektierteZelleFarbhintergrundAufColorIndexSetzen()
Dim s_input As String, l_colorindex As Long
On Error Resume Next
Do
s_input = InputBox( _
Bitte geben sie die Nummer des Colorindex an (1-56), _
Hintergrundfarbe der Markierten Zellen aus Colorindex setzen, _
)
If s_input = Then Exit Sub
If Len(s_input) <= 2 Then
l_colorindex = s_input
If Err.Number <> 0 Then
Err.Clear
GoTo Nochmal
Else
If l_colorindex >= 1 And l_colorindex <= 56 Then Exit Do
End If
End If
Nochmal:
MsgBox (Bitte eine Zahl zwischen 1 und 56 eingeben.)
Loop
->Farbhintergrund der markierte Zellen entsprechend dem Colorindex setzen
Selection.Interior.ColorIndex = l_colorindex
End Sub
'************************************************
Sub TabelleFarbhintergrund_FürAlleRGBFarben()
Const c_MAX_ANZ_SPALTEN = 18
Dim wb As Workbook, ws As Worksheet
Dim l_spalte As Long, l_zeile As Long
Dim rot As Integer, gruen As Integer, blau As Integer
->neue Mappe anlegen
Set wb = Workbooks.Add
Set ws = wb.Worksheets(1)
l_zeile = 0
l_spalte = c_MAX_ANZ_SPALTEN
For rot = 0 To 255 Step 15
For gruen = 0 To 255 Step 15
For blau = 0 To 255 Step 15
l_spalte = l_spalte + 1
->c_MAX_ANZ_SPALTEN überschritten ?
If l_spalte > c_MAX_ANZ_SPALTEN Then
->nächste Zeile
l_spalte = 1
l_zeile = l_zeile + 1
End If
ws.Cells(l_zeile, l_spalte).Interior.Color = RGB(rot, gruen, blau)
ws.Cells(l_zeile, l_spalte).NumberFormat = @
ws.Cells(l_zeile, l_spalte).Value = rot & , & gruen & , & blau
Next
Next
Next
For l_spalte = 1 To c_MAX_ANZ_SPALTEN: ws.Columns(l_spalte).AutoFit: Next
Aufraeumen:
Set ws = Nothing: Set wb = Nothing
End Sub
