RGB Farben automatisieren

[Markus1234]

Hallo zusammen,

ich möchte in der Spalte F die Zellen 2 bis 1.000.001 mit der nebenstehenden RGB-Farbe (bzw. #Hex) füllen. Einmalig automatisiert. Soll nicht dauerhaft überprüft/angepasst werden.

Kann mir jemand einen RAM-Sparsamen Vorschlag machen? KI taugt leider genausoviel wie ich.

Liebe Güße
Markus

[Ralf A]

Hallo zusammen,

ich möchte in der Spalte F die Zellen 2 bis 1.000.001 mit der nebenstehenden RGB-Farbe (bzw. #Hex) füllen. Einmalig automatisiert. Soll nicht dauerhaft überprüft/angepasst werden.

Kann mir jemand einen RAM-Sparsamen Vorschlag machen? KI taugt leider genausoviel wie ich.

Liebe Güße
Markus

...RAM spart man am Besten, wenn man sich solch eine Datei erspart... 

Aber ok.... folgenden Code in das Modul der betreffenden Tabelle:

PHP-Code:

Option Explicit

Sub ShowColor()
Dim r As Byte, g As Byte, b As Byte, zeile As Double
Cells(1, 8) = "Start"
Cells(1, 9) = Now

Rows("2:70000").Delete
On Error GoTo Fehler
Range("A2:F" & Cells.SpecialCells(xlCellTypeLastCell).Row).Clear
Application.ScreenUpdating = False

Columns(5).NumberFormat = "@"
zeile = 2
    For r = 0 To 254 Step 5
        For g = 0 To 254 Step 5
            For b = 0 To 254 Step 5
            Application.StatusBar = "Zeile: " & zeile & " | r, g, b: " & r & ", " & g & ", " & b
                If zeile <= 65000 Then
                    Cells(zeile, 1) = zeile - 1
                    Cells(zeile, 2) = r
                    Cells(zeile, 3) = g
                    Cells(zeile, 4) = b
                    Cells(zeile, 5) = CStr(Hex(zeile - 2))
                    Cells(zeile, 5).Value = Right("00000" & Cells(zeile, 5), 6)
                    Cells(zeile, 6).Interior.Color = RGB(r, g, b)
                   
                    zeile = zeile + 1
                Else
                    GoTo Ende
                End If
            Next b
        Next g
    Next r
Ende:
Cells(2, 8) = "Ende"
Cells(2, 9) = Now
MsgBox "r, g, b: " & r & ", " & g & ", " & b
Application.ScreenUpdating = True
Application.StatusBar = ""
Exit Sub
Fehler:
Cells(2, 8) = "Ende"
Cells(2, 9) = Now
MsgBox "Zeile: " & zeile & vbCrLf & Err.Description
Application.ScreenUpdating = True
Application.StatusBar = ""
Err.Clear

End Sub


Hab Dir das mal in 5er Schritten und nur für 65000 Farben gemacht. Noch mehr Farben überschreiten irgendwann das Limit der zulässigen Formate. Das sollte aber trotzdem ausreichen. Wenn nicht gewollt, dann alle Step 5 Anweisungen entfernen oder neue Start- und Endpunkte für rgb festlegen.
Fortschritt wird in der Statusbar angezeigt. Programm braucht aber trotzdem seine Zeit.

[Markus1234]

Mega, vielen Dank!!!!!

Ich konnte den Code anwenden. Darf ich dich um eine Änderung bitten?
Kannst du die RGB-Werte aus den Spalten B, C und D übernehmen? Dein Code erstellt mir "nur" die ersten 1. Mio Farben. Ich will natürlich alle   (in 17 Mappen - soweit der Plan)

Außerdem kommt nach ca. 60.000 Farben eine Fehlermeldung (Anhang). Ich vermute aber, dass ich die durch meinen Änderungswunsch umgehen könnte (wenn ich die Startzeile im angepassten Code immer neu anpasse... ziemlich friemelig, aber 1000000 x besser als alles manuell :D:D:D)

Also ganz ganz vielen Dank schonmal!

[Ralf A]

Mega, vielen Dank!!!!!

Ich konnte den Code anwenden. Darf ich dich um eine Änderung bitten?
Kannst du die RGB-Werte aus den Spalten B, C und D übernehmen? Dein Code erstellt mir "nur" die ersten 1. Mio Farben. Ich will natürlich alle   (in 17 Mappen - soweit der Plan)

Außerdem kommt nach ca. 60.000 Farben eine Fehlermeldung (Anhang). Ich vermute aber, dass ich die durch meinen Änderungswunsch umgehen könnte (wenn ich die Startzeile im angepassten Code immer neu anpasse... ziemlich friemelig, aber 1000000 x besser als alles manuell :D:D:D)

Also ganz ganz vielen Dank schonmal!

Du meinst, die RGB Werte aus Zeile 2 als Startwerte?
Ich bin mir nicht sicher, aber das Limit für die Formatanzahl gilt nicht für jedes Blatt einzeln, sondern für die ganze Datei. Kannst Du ja selbst mal googeln. Wenn das für die ganze Datei gilt, musst Du Dir eben mehrere Von/Bis Dateien anlegen.

Code mit RGB Startwerten aus Zeile 2:

PHP-Code:

Option Explicit

Sub ShowColor()
Dim r As Byte, g As Byte, b As Byte, zeile As Double, nr As Double

Cells(1, 8) = "Start"
Cells(1, 9) = Now
nr = Cells(2, 1)
Columns(5).NumberFormat = "@"
Range("I1:I2").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"

Rows("3:70000").Delete
On Error GoTo Fehler
Range("A3:F" & Cells.SpecialCells(xlCellTypeLastCell).Row).Clear
Application.ScreenUpdating = False


zeile = 2
For r = Cells(2, 2) To 254 Step 5
For g = Cells(2, 3) To 254 Step 5
For b = Cells(2, 4) To 254 Step 5
Application.StatusBar = "Zeile: " & zeile & " | r, g, b: " & r & ", " & g & ", " & b

If zeile <= 65000 Then
Cells(zeile, 1) = nr
Cells(zeile, 2) = r
Cells(zeile, 3) = g
Cells(zeile, 4) = b
Cells(zeile, 5) = CStr(Hex(zeile - 2))
Cells(zeile, 5).Value = Right("00000" & Cells(zeile, 5), 6)
Cells(zeile, 6).Interior.Color = RGB(r, g, b)

zeile = zeile + 1
nr = nr + 1
Else
GoTo Ende
End If
Next b
Next g
Next r
Ende:
Cells(2, 8) = "Ende"
Cells(2, 9) = Now
Cells(3, 8) = "R"
Cells(3, 9) = r
Cells(4, 8) = "G"
Cells(4, 9) = g
Cells(5, 8) = "B"
Cells(5, 9) = b
Cells(6, 8) = "nächste Nr.:"
Cells(6, 9) = nr
MsgBox "r, g, b: " & r & ", " & g & ", " & b
Application.ScreenUpdating = True
Application.StatusBar = ""
Exit Sub

Fehler:
Cells(2, 8) = "Ende - bei Fehler in Zeile " & zeile
Cells(2, 9) = Now
Cells(3, 8) = "R"
Cells(3, 9) = r
Cells(4, 8) = "G"
Cells(4, 8) = g
Cells(5, 8) = "B"
Cells(5, 9) = b
Cells(6, 8) = "nächste Nr.:"
Cells(6, 9) = nr

MsgBox "Zeile: " & zeile & vbCrLf & Err.Description
Application.ScreenUpdating = True
Application.StatusBar = ""
Err.Clear

End Sub


[slowboarder]

Hi
vielleicht mit diesem Formelwerk
A2: =ZEILE(A1)-1
B2: =REST(QUOTIENT(A2;256^0);256)
C2: =REST(QUOTIENT(A2;256^1);256)
D2: =REST(QUOTIENT(A2;256^2);256)
E2: =DEZINHEX(D2;2)&DEZINHEX(C2;2)&DEZINHEX(B2;2)

das dann soweit nach unten ziehen wie benötigt (A1000001)

für die weiteren Spalten (du brauchst ja 17) änderst du dann die Formel in A2 so ab (G2, wenn du die Spalten mit einer Spalte abstand auf dem selben Blatt nebeneinenander platzierst)

G2: =Zeile(G1)+A$1000001
dh das ist quasi der Startwert-1 für diese Seite.
die anderen Formeln kannst du mit Copy-Paste übernehmen
wenn du den zweiten Block so aufgebaut hast, kannst du diesen einfach komplett kopieren und nebenan einfügen.


aber zum Vergüngen auch noch mal eine VBA-Lösung.
Das Ergebnis wird auf dem selben Blatt nebeneinander dargstellt, aber das lässt sich auch einfach auf mehrere Blätter oder Dateien ausbauen.
wenn man wirklich Speicherplatz sparen wollte, könnte man auch die Ergebnisse sofort ins Blatt schreiben, anstatt sie erstmal im Sammelarray (erg1) zu sammeln, aber so lässt sich der Vorgang: Liste erstellen leichter von der Ausgabe trennen.

PHP-Code:

Sub test()

Dim r As Long, g As Long, b As Long
Dim h(0 To 255) As String
Dim i As Long
Const anz As Long = 1000000

Dim erg1(0 To 16)
ReDim erg2(0 To anz - 1, 0 To 4)

Dim Blatt As Long
Dim x As Long, y As Long


For i = 0 To 255
    h(i) = WorksheetFunction.Dec2Hex(i, 2)
Next



For b = 0 To 255
    Application.StatusBar = "Liste erstellen " & b & " von 256"
    For g = 0 To 255
        For r = 0 To 255
            erg2(y, 0) = x
            erg2(y, 1) = r
            erg2(y, 2) = g
            erg2(y, 3) = b
            erg2(y, 4) = "'" & h(b) & h(g) & h(r)
            x = x + 1
            y = y + 1
            If y = anz Then
                erg1(Blatt) = erg2
                Blatt = Blatt + 1
                y = 0
                ReDim erg2(0 To anz - 1, 0 To 4)
            End If
               
        Next
    Next
Next
erg1(Blatt) = erg2

For Blatt = 0 To UBound(erg1)
    Application.StatusBar = "Schreibe Spalte " & Blatt + 1 & " von 17"
    Cells(2, Blatt * 6 + 1).Resize(anz, 5) = erg1(Blatt)
Next

Application.StatusBar = False
End Sub


Gruß Daniel

[Markus1234]

Danke für eure Beiträge.

Ich versuche das Problem mit den begrenzten Formatierungen zu umgehen, indem ich Word-Dokumente verwende. Ich scheitere aber im Moment an meiner Windows XP Rechenleistung
30.000 Zeilen Tabelle habe ich geschafft, bei 60.000 ist Word abgestürzt. (65.000 sind 1/256 vom Gesamten).

Ich halte euch auf dem Laufenden. Dauert aber evtl. ein paar Tage.

[HKindler]

Hi,

mal 'ne doofe Frage: wofür braucht man sowas?
Reicht da nicht der normale Farb-Einsteller von Excel (oder jedem anderen Programm)?

[Andreas Killer]

mal 'ne doofe Frage: wofür braucht man sowas?

Die Frage ist alles andere als doof.

Diese Art Dialoge gibt es überall, in Windows 11 ist sogar einer der den dazugehörigen Namen der Farbe mit ausgibt und warnt wenn ein so gefärbter Text auf einem Hintergrund schlecht zu lesen ist.
   

Aber spaßeshalber kann man ja mal drüber nachdenken:

Wir kriegen nur etwas mehr als 65.000 Farben in eine Datei / 65.490 Eindeutige Zellformate:
https://support.microsoft.com/de-de/offi...9d656771c3

Rechnen wir mal RGB(255,255,255) = 16.777.215 / 65000 ≈ 258 Dateien á mittlere Excel-Dateigröße von 2,5Mb ≈ 0,6Gb. Nehmen wir mal an wir würden das als PDF speichern und am Ende alle PDF zu einem File vereinigen, dann kommen wir bei einer mittleren PDF-Größe von 5Mb auf ≈ 1,3Gb PDF.

Es ist wohl möglich Dateien (welche auch immer) dieser Größenordnung zu erzeugen, vorausgesetzt die Spezifikationen erlauben das. Aber mal ehrlich, selbst ein heutiger Spitzenrechner mit ausreichend Leistung wird allein zum Öffnen dieser Datei einige Minuten brauchen.

Und selbst wenn, was will man dann da drin machen? Suchen? Scrollen und kucken?

Visualisieren wir das mal, wie wäre es denn mit Ausdrucken? 258 Dateien á ≈ 1400 DIN-A4 Seiten = 361.200 Blätter bei einem üblichen Papiergewicht von 80g/m² gibt das ≈ 1,8 Tonnen Papier.

Andreas.

[RPP63]

… zumal das menschliche Auge nur grob 200 Farben unterscheiden kann …
Machen wir doch mal ein kleines Experiment!
R: 235 bis 255
G: 0 bis 20
B: 0 bis 20
ergibt Farbwerte von 235 bis 1.250.302

Arbeitsblatt:

Code:

Private Sub Worksheet_Calculate()
Dim i&
For i = 2 To 21
  Cells(i, 4).Interior.Color = RGB(Cells(i, 1), Cells(i, 2), Cells(i, 3))
Next
End Sub

Allgemeines Modul:

Code:

Function Farbwert&(r&, g&, b&)
Farbwert = RGB(r, g, b)
End Function

Ergibt:

	A	B	C	D	E
1	R	G	B	Farbe	Farbwert
2	235	0	0		235
3	236	1	1		66.028
4	237	2	2		131.821
5	238	3	3		197.614
6	239	4	4		263.407
7	240	5	5		329.200
8	241	6	6		394.993
9	242	7	7		460.786
10	243	8	8		526.579
11	244	9	9		592.372
12	245	10	10		658.165
13	246	11	11		723.958
14	247	12	12		789.751
15	248	13	13		855.544
16	249	14	14		921.337
17	250	15	15		987.130
18	251	16	16		1.052.923
19	252	17	17		1.118.716
20	253	18	18		1.184.509
21	254	19	19		1.250.302

Zelle	Formel
E2	=Farbwert(A2;B2;C2)

Viel Spaß beim Erkennen der Farbunterschiede! 

Gruß Ralf

[xlKing]

Hallo und Guten Abend,

da hab ich mich nun also hier auch noch angemeldet. Über Sinn und Unsinn dieses Wunsches kann man streiten. Fakt ist, auch ich habe in meinen ersten Tagen eine ähnliche Liste mit Farben generiert. Allerdings hatte ich das System dann irgendwann durchschaut, sodass eine vollständige Liste nie nötig war. 

Ich würde, um die Liste vollständig RAM-Sicher umzusetzen über ein Userform gehen. Dies hat den Vorteil, dass man nur die Labels aktualisieren muss, die auch sichtbar sind. Da spart man sich das Problem mit der begrenzten Format-Anzahl.

Erstelle also ein Userform (egal ob in Excel oder Word) und gib dort diesen Code ein:

Code:

Dim WithEvents myFrame As MSForms.Frame
Dim ScrollValue As Long
Const Zeilen = 32
Const Hoehe = 12

Private Sub myFrame_Scroll(ByVal ActionX As MSForms.fmScrollAction, ByVal ActionY As MSForms.fmScrollAction, ByVal RequestDx As Single, ByVal RequestDy As Single, ByVal ActualDx As MSForms.ReturnSingle, ByVal ActualDy As MSForms.ReturnSingle)
   Select Case ActionY
   Case 1
   ScrollValue = ScrollValue - 1
   Case 2
   ScrollValue = ScrollValue + 1
   Case 3
   ScrollValue = ScrollValue - Zeilen
   Case 4
   ScrollValue = ScrollValue + Zeilen
   Case 7
     ScrollValue = myFrame.ScrollTop + RequestDy
     If ScrollValue + RequestDy >= RGB(255, 255, 255) Then ScrollValue = RGB(255, 255, 255) - Zeilen + 1
   End Select
   
   If ScrollValue > RGB(255, 255, 255) Then ScrollValue = RGB(255, 255, 255)
   If ScrollValue < 0 Then ScrollValue = 0
   
   
   For i = 1 To Zeilen
     Controls("Nummer_" & i) = ScrollValue + i - 1
     Controls("R_" & i) = Int((ScrollValue + i - 1) / 256 ^ 0) Mod 256
     Controls("G_" & i) = Int((ScrollValue + i - 1) / 256 ^ 1) Mod 256
     Controls("B_" & i) = Int((ScrollValue + i - 1) / 256 ^ 2) Mod 256
     Controls("Hex_" & i) = String(6 - Len(Hex((ScrollValue + i - 1))), "0") & Hex((ScrollValue + i - 1))
     Controls("Color_" & i).BackColor = ScrollValue + i - 1
   Next i
End Sub

Private Sub UserForm_Initialize()




height = (Zeilen + 1) * Hoehe + 29.25
Width = 220


For i = 0 To Zeilen + 1
   
  With Controls.Add("Forms.Label.1")
    .Left = 0
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 60
    .Caption = IIf(.Top = 0, "Nummer", (i - 1))
    .TextAlign = fmTextAlignCenter
    .Font.Size = 8
    .AutoSize = False
    .Name = "Nummer_" & i
  End With
 
  With Controls.Add("Forms.Label.1")
    .Left = 60
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 20
    .Caption = IIf(.Top = 0, "R", Int((i - 1) / 256 ^ 0) Mod 256)
    .ForeColor = RGB(255, 0, 0)
    .TextAlign = fmTextAlignCenter
    .Font.Size = 8
    .AutoSize = False
    .Name = "R_" & i
  End With
 
  With Controls.Add("Forms.Label.1")
    .Left = 80
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 20
    .Caption = IIf(.Top = 0, "G", Int((i - 1) / 256 ^ 1) Mod 256)
    .ForeColor = RGB(0, 128, 0)
    .TextAlign = fmTextAlignCenter
    .Font.Size = 8
    .AutoSize = False
    .Name = "G_" & i
  End With
 
  With Controls.Add("Forms.Label.1")
    .Left = 100
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 20
    .Caption = IIf(.Top = 0, "B", Int((i - 1) / 256 ^ 2) Mod 256)
    .ForeColor = RGB(0, 0, 255)
    .TextAlign = fmTextAlignCenter
    .Font.Size = 8
    .AutoSize = False
    .Name = "B_" & i
  End With
 
  With Controls.Add("Forms.Label.1")
    .Left = 120
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 30
    .Caption = IIf(.Top = 0, "HEX", String(6 - Len(Hex((i - 1))), "0") & Hex((i - 1)))
    .TextAlign = fmTextAlignCenter
    .Font.Size = 8
    .AutoSize = False
    .Name = "Hex_" & i
  End With
 
  With Controls.Add("Forms.Label.1")
    .Left = 150
    .Top = i * Hoehe
    .height = Hoehe
    .Width = 40
    .Caption = IIf(.Top = 0, "Farbe", "")
    If i > 0 Then .BackColor = i - 1
    .TextAlign = fmTextAlignCenter
    .Name = "Color_" & i
  End With
 
Next i
 
  Set myFrame = Controls.Add("Forms.Frame.1")
  With myFrame
    .Left = 190
    .Top = Hoehe
    .Width = 20
    .height = Zeilen * Hoehe
    .BorderStyle = fmBorderStyleNone
    .ScrollBars = fmScrollBarsVertical
    .ScrollHeight = RGB(255, 255, 255)
  End With
 
 
End Sub

Wenn du das Userform startest kannst du durch Scrollen, immer die gleichen Labels aktualisieren. Deshalb geht das superschnell. Beachte: Bei VBA ist in einem RGB-Hexcode das R ganz rechts. Damit unterscheidet sich der Code von einem HTML-Hexcode, wo das R links ist. Grund in VBA werden führende Nullen abgeschnitten. &H0000FF und &HFF ist also dasselbe.

Gruß Mr. K.