Sub RGBAnzeige()
' auf Grundlage von einem Code von Nepumuk
Dim Rot As Long, Grün As Long, Blau As Long, Wert As Long
' ****** Ergänzung Hajo
Dim i As Integer
For i = 1 To 56
' Farbe in Spalte A
Cells(i, 1).Interior.ColorIndex = i
Wert = Cells(i, 1).Interior.Color
On Error Resume Next
Rot = Wert Mod 256
Wert = (Wert - Rot) / 256
Grün = Wert Mod 256
Wert = (Wert - Grün) / 256
Blau = Wert Mod 256
' MsgBox Rot & ", " & Grün & ", " & Blau
' ***** Ergänzung Hajo
Cells(i, 3) = Rot
Cells(i, 4) = Grün
Cells(i, 5) = Blau
Next i
'***** Ergänzung Hajo
Cells(57, 3) = "Rot"
Cells(57, 4) = "Grün"
Cells(57, 5) = "Blau"
Cells(58, 3) = "RGB Farbwerte"
End Sub
Sub ZellenFaerben()
'17.08.2009, NoNet - www.excelei.de
Dim lngZ As Long
For lngZ = 1 To 56
Cells(lngZ, 1).Interior.ColorIndex = lngZ
Cells(lngZ, 2) = ActiveWorkbook.Colors(lngZ)
Cells(lngZ, 3).Resize(, 3) = rgbFarbe(ActiveWorkbook.Colors(lngZ))
Next
End Sub
Sub ZellenFaerben()
'17.08.2009, NoNet - www.excelei.de
Dim lngZ As Long
For lngZ = 1 To 56
Cells(lngZ, 1).Interior.ColorIndex = lngZ
Cells(lngZ, 2) = ActiveWorkbook.Colors(lngZ)
Cells(lngZ, 3).Resize(, 3) = rgbFarbe(ActiveWorkbook.Colors(lngZ))
Next
End Sub
Function rgbFarbe(dblRGB)
'15.07.2009, NoNet
'Aufruf z.B. durch :
'MsgBox rgbFarbe(12345)(0) => ROT-Wert
'MsgBox rgbFarbe(12345)(1) => GRÜN-Wert
'MsgBox rgbFarbe(12345)(2) => BLAU-Wert
Dim R, G, B
R = dblRGB \ 256 ^ 2
G = (dblRGB - (256 ^ 2) * R) \ 256
B = ((dblRGB - (256 ^ 2) * R) - 256 * G)
rgbFarbe = Array(R, G, B)
End Function
Hallo NoNet,
ich würde gerne des in der Mappe so reinbauen, was in Zelle A1 steht soll auf der
ganzen Mappe mit der Farbe bzw. den Format von Zelle B1 (nicht Hintergrundfarbe,
evtl auch die Rahmen) gefärbt werden.
Was in Zelle A2 steht und des identisch ist mit soll mit B2 gefärbt werden.
If IsError(rngC) Then
Exit For
ElseIf rngC = arrA(aa) Then
If rngC = arrA(aa) Then
If IsError(rngC) And Not IsError(arrA(aa)) Then
ElseIf rngC = arrA(aa) Then
If Not IsEmpty(rngC) Then
For aa = 1 To UBound(arrA) Step 2
If IsError(rngC) And Not IsError(arrA(aa)) Then
ElseIf rngC = arrA(aa) Then
With Cells(2, aa + 1)
Option Explicit
Private Sub xWorksheet_Change(ByVal Target As Range)
Dim lngS As Long, arrA, rngA As Range, rngC As Range, aa As Long
lngS = Cells(2, Columns.Count).End(xlToLeft).Column
arrA = Application.Transpose(Application.Transpose(Cells(2, 1).Resize(, lngS)))
For Each rngA In Target.Areas
For Each rngC In rngA
If rngC.Row > 2 Then
If Not IsEmpty(rngC) Then
For aa = 1 To UBound(arrA) Step 2
If IsError(rngC) And Not IsError(arrA(aa)) Then
ElseIf rngC = arrA(aa) Then
With Cells(2, aa + 1)
rngC.Font.ColorIndex = .Font.ColorIndex ' Schriftfarbe
With .Interior ' Hintergrund
rngC.Interior.ColorIndex = .ColorIndex
rngC.Interior.Pattern = .Pattern ' Muster
rngC.Interior.PatternColorIndex = .PatternColorIndex
End With
With .Borders ' Rahmen
rngC.Borders.Weight = .Weight
rngC.Borders.ColorIndex = .ColorIndex
rngC.Borders.LineStyle = .LineStyle
End With
End With
Exit For
End If
Next aa
End If
If aa = 0 Or aa > UBound(arrA) Then
With rngC
.Font.ColorIndex = xlColorIndexAutomatic ' Schriftfarbe
With .Interior ' Hintergrund
.ColorIndex = xlColorIndexAutomatic
.Pattern = xlPatternNone ' Muster
End With
.Borders.LineStyle = xlLineStyleNone ' Rahmen
End With
End If
End If
Next rngC
Next rngA
End Sub