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