Thema: Zellfarbe in Nebenzellen, Farbindex, RGB Werte, Farbnummer

Guten Tag an alle …

Sachverhalt:
In Tabelle1 markiere ich Zelle B5. Dann löse ich ein Makro aus, das folgendes erledigt:
Zelle C5 (Farbzelle) wird markiert und in Zelle D5 bis F5 wird Farbindex, RGB Werte und Farbnummer eingetragen. Das funktioniert alles.

Mein Wunsch ist, wie muss der Code sein:
Zelle B5 markieren, dann Code "FarbIndex" mit Folgecodes ausführen.
Dann B6 markieren und ebenfalls gleichen Code "FarbIndex" mit Folgecodes ausführen.
Entsprechen diese Folge bis Zelle B507.

Meine Versuche reichen leider nur soweit, dass ich die einzelnen Zellen in Spalte B markieren muss und dann jeweils den Code ausführen lassen.
An bei eine Beispieldate mit den bisherigen Code:
https://www.herber.de/bbs/user/170779.xlsm

Mit der Bitte um Hilfe,
grüßt
Dieter(Drummer)

Das sind die bisherigen Codes:

Public Sub Farbe_etc()

Sheets("Tabelle1").Range("B5").Select

  Call FarbIndex

Range("B6").Select

  Call FarbIndex

'Bis inkl. Zelle 507

End Sub

Code FarbIndex:

Sub FarbIndex()

  ActiveCell(1, 2).Select 'Zellebereich NUR Spalte 2

     ActiveCell.Offset(0, 1).Value = ActiveCell.Interior.ColorIndex

     ActiveCell.Offset(0, 3).Value = ActiveCell.Interior.Color

  Call RGB_Werte

End Sub

Code RGB Werte:
'RGB Werte in 2te Nebenzelle schreiben

Sub RGB_Werte()

ActiveCell.Offset(0, 2).Value = ActiveCell

Dim Farbwert As Long

Dim Rot

Dim Grün

Dim Blau

Farbwert = ActiveCell.Interior.Color

On Error Resume Next

Rot = Farbwert Mod 256

Farbwert = (Farbwert - Rot) / 256

Grün = Farbwert Mod 256

Farbwert = (Farbwert - Grün) / 256

Blau = Farbwert Mod 256

ActiveCell.Offset(0, 2).Value = Rot & ", " & Grün & ", " & Blau

End Sub

Hallo Dieter,

Public Sub Farbe_etc() solltest du so ändern:

Public Sub Farbe_etc()

Dim Zeile As Long



For Zeile = 2 To 507

Sheets("Tabelle1").Range("B" & Zeile).Select

Call FarbIndex

Next Zeile

End Sub

Damit erstellst du eine Schleife die von Zeile 2 bis zur Zeile 507 durchläuft

Hallo Riebi,

Danke für deinen Code, der perfekt funtioniert.
Habe wohl noch zwei Anpassungen/Änderungen gemacht und es läuft perfekt.
Application.Screenupdating = false ergit ein sehr schnelles einfügen der Werte etc. und Zeile 2 habe ich auf Zele 5 gesetzt. Klappt alles perfekt.

Danke und einen schönen Tag.

Gruß,
Dieter(Drummer

Hier der geänderte Code von dir:

Public Sub Farbe_etc()

Application.ScreenUpdating = False

Dim Zeile As Long

For Zeile = 5 To 507

Sheets("Tabelle1").Range("B" & Zeile).Select

Call FarbIndex

Next Zeile

End Sub

Erst mal Vorarbeit leisten:
Aus

Sub FarbIndex()

machst du

Sub FarbIndex(rng as Range)

Und SÄMTLICHE "ActiveCell" in "Farbindex" änderst du in "rng".
Und das selbe auch mit

Sub RGB_Werte()

Dadurch ist es möglich, der Sub beim Aufruf einen Parameter, nämlich die Zelle, mit zu übergeben, womit er alles macht (statt mit ActiveCell).
Wenn du das hast, poste den Code erneut.

Hallo,
ich würde mir 3 Functions definieren und die in die Zellen schreiben.

In ein Modul:

Function Farbe(rng As Range)

  Farbe = rng.Interior.Color

End Function



Function FarbIndex(rng As Range)

  FarbIndex = rng.Interior.ColorIndex

End Function



Function RGB_Werte(rng As Range)

  Dim lngFarbe As Long

  Dim R As Integer

  Dim G As Integer

  Dim B As Integer

  

  lngFarbe = rng.Interior.Color

  R = lngFarbe Mod 256

  lngFarbe = (lngFarbe - R) / 256

  G = lngFarbe Mod 256

  lngFarbe = (lngFarbe - G) / 256

  B = lngFarbe Mod 256

  

  RGB_Werte = Join(Array(R, G, B), "; ")

End Function

B5: =FarbIndex(A5)
C5: =Farbe(A5)
D5: =RGB_Werte(A5)
und runter kopieren.

Gruß aus'm Pott
Udo

Hi Dieter
alles Gute zum Geburtstag.

ich würde das mit Funktionen lösen, die ich dann in die zellen Eintrage.

hier der Code:

Sub Einfügen()

With Selection.Offset(0, 1).Resize(, 3)

    .Columns(1).FormulaR1C1 = "=FarbID(RC[-1])"

    .Columns(2).FormulaR1C1 = "=FarbNr(RC[-2])"

    .Columns(3).FormulaR1C1 = "=FarbRGB(RC[-3])"

    .Formula = .Value

End With

End Sub





Function FarbNr(Zelle As Range)

    FarbNr = Zelle(1).Interior.Color

End Function



Function FarbID(Zelle As Range)

    FarbID = Zelle(1).Interior.ColorIndex

End Function



Function FarbRGB(Zelle As Range)

Dim Farbwert As Long

Dim Rot As Long

Dim Grün As Long

Dim Blau As Long

Farbwert = Zelle(1).Interior.Color

Rot = Farbwert Mod 256

Farbwert = (Farbwert - Rot) / 256

Grün = Farbwert Mod 256

Farbwert = (Farbwert - Grün) / 256

Blau = Farbwert Mod 256

FarbRGB = Rot & ", " & Grün & ", " & Blau

End Function

markiere dann die Zellen mit den Farben ("B5:B507") und starte das Makro "Einfügen"

Gruß Daniel

Danke Daniel für die Glückwünsche.

Mit den Funktionen ist auch eine gute Lösung. Vielen Dank.

Gruß und einen erfreulichen Tag,
Dieter(Drummer)

Danke Udo,

dies wäre auch eine funktionierende Variante.

Danke und Gruß,
Dieter(Drummer)

Danke Onur für Rückmeldung und Hinweise.
Werde es ändern und mich dann zurück melden.

Gruß, Dieter(Drummer)

Hallo Onur,

hier der jetzt geänderte Code.
Ich muss wohl vorher die Zelle links neben der Farbzelle markieren, z.B. B5, dann den Code "Farbindex" starten, dann werden in z.B. D5.F5 die entsprechenden Werte eingefügt.
Aber nur in dieser Zeile. Es läuft nicht weiter bis Zeile 507.

Würde mich auch interessieren, was da noch anders sein muss.
Auch wenn ich den funktionierenden Code von Reibi habe.

Hier der jetzige Code:

Sub FarbIndex(rng As Range)

  rng(1, 2).Select 'Zellenbereich NUR Spalte 2

     rng.Offset(0, 1).Value = rng.Interior.ColorIndex

     rng.Offset(0, 3).Value = rng.Interior.Color

'RGB Werte in 2te Nebenzelle

     Call RGB_Werte

End Sub

'RGB Werte in 2te Nebenzelle schreiben

Sub RGB_Werte()

rng.Offset(0, 2).Value = rng

Dim Farbwert As Long

Dim Rot

Dim Grün

Dim Blau

Farbwert = rng.Interior.Color

On Error Resume Next

Rot = Farbwert Mod 256

Farbwert = (Farbwert - Rot) / 256

Grün = Farbwert Mod 256

Farbwert = (Farbwert - Grün) / 256

Blau = Farbwert Mod 256

rng.Offset(0, 2).Value = Rot & ", " & Grün & ", " & Blau

End Sub

So rufst du die Schleife auf:

    Dim cel

    For Each cel In Range("B5:B507")

        Call farbindex(cel)

    Next

Aber vorher

Call RGB_Werte

in Sub "farbindex" ändern in

Call RGB_Werte(rgb)

Sollte dann laufen.

Hallo Onur,

so sieht jetzt mein Code aus und es kommt ein Fehler:
Fehler beim Kompilieren, Argumtenttyp ByRef unverträglch, in Zeile "Call by Farbindex(Cel) und "cel" wird markiert).

Hab ich da etwas falsches gemacht?

Mit Gruß,
Dieter(Drummer)
Code:

Public Sub Farbe()

    Dim cel

    For Each cel In Range("B5:B507")

        Call Farbindex(cel)

    Next

End Sub

Sub Farbindex(rng As Range)

  rng(1, 2).Select 'Zellenbereich NUR Spalte 2

     rng.Offset(0, 1).Value = rng.Interior.ColorIndex

     rng.Offset(0, 3).Value = rng.Interior.Color

'RGB Werte in 2te Nebenzelle

     Call RGB_Werte

End Sub

'RGB Werte in 2te Nebenzelle schreiben

Sub RGB_Werte()

rng.Offset(0, 2).Value = rng

Dim Farbwert As Long

Dim Rot

Dim Grün

Dim Blau

Farbwert = rng.Interior.Color

On Error Resume Next

Rot = Farbwert Mod 256

Farbwert = (Farbwert - Rot) / 256

Grün = Farbwert Mod 256

Farbwert = (Farbwert - Grün) / 256

Blau = Farbwert Mod 256

rng.Offset(0, 2).Value = Rot & ", " & Grün & ", " & Blau

End Sub

Sub RGB_Werte(ByRef rng as Range)

muss da stehen.
Ändere bitte

Sub Farbindex(rng As Range)

auch um in

Sub Farbindex(ByRef rng As Range)

Hallo,
läuft bei mir:

Option Explicit



Public Sub Farbe()

    Dim cel As Range

    For Each cel In Range("B5:B507")

        Call Farbindex(cel)

    Next

End Sub



Sub Farbindex(rng As Range)

  'rng(1, 2).Select 'Zellenbereich NUR Spalte 2

     rng.Offset(0, 1).Value = rng.Interior.ColorIndex

     rng.Offset(0, 3).Value = rng.Interior.Color

'RGB Werte in 2te Nebenzelle

     Call RGB_Werte(rng)

End Sub



'RGB Werte in 2te Nebenzelle schreiben

Sub RGB_Werte(rng)

  Dim Farbwert As Long

  Dim Rot

  Dim Grün

  Dim Blau

  Farbwert = rng.Interior.Color

  On Error Resume Next

  Rot = Farbwert Mod 256

  Farbwert = (Farbwert - Rot) / 256

  Grün = Farbwert Mod 256

  Farbwert = (Farbwert - Grün) / 256

  Blau = Farbwert Mod 256

  rng.Offset(0, 2).Value = Rot & ", " & Grün & ", " & Blau

End Sub

Gruß aus'm Pott
Udo

Hallo Udo,

läuft bei mir ncht richtig, da die Eintragungen schon in Spalte C anfangen, statt ab Spalte D.

Gruß, Dieter(Drummer)

Hallo,
es ist doch kein Problem, die OffSet-Werte zu ändern.
eingedampft:

Option Explicit



Public Sub Farbe()

    Dim rng As Range

    For Each rng In Range("B5:B507")

     rng.Offset(0, 2).Value = rng.Interior.ColorIndex 'D

     rng.Offset(0, 3).Value = rng.Interior.Color      'E

     rng.Offset(0, 4) = RGBWerte(rng)                 'F

    Next

End Sub



Function RGBWerte(rng As Range)

  Dim Farbwert As Long

  Dim R As Byte

  Dim G As Byte

  Dim B As Byte

  Farbwert = rng.Interior.Color

  

  R = Farbwert Mod 256

  Farbwert = (Farbwert - R) / 256

  G = Farbwert Mod 256

  Farbwert = (Farbwert - G) / 256

  B = Farbwert Mod 256

  RGBWerte = R & ", " & G & ", " & B

End Function

Gruß aus'm Pott
Udo

... Muss jetzt leider aufhören, da ich in Vorbereitungen für meinen morgigen Geburtstag,, der 80zigste :-), bin

Danke an alle und Gruß,
Dieter(Drummer),

Dann an dieser Stelle einmal herzlichen Glückwunsch und alles Gute zu deinem 80. :)

Herzlichen Dank für deinen Glückwunsch.

Gruß,
Dieter(Drummer)

Moin Dieter
Auch von mir Happy Birthday.
Dann musst du ja die Schiessbude wieder aus dem Keller holen.
Und ab jetzt alles im dreivierteltakt ;-)))
Nix mehr mit "Headbanging"
gruss hary

Danke Hary für deine Glückwünsche, hat mich sehr gefreut.

Gruß und ein angenehmen Tag,
Dieter(Drummer)

Danke Our für deine weitere Hilfe,

es kommt abr immer noch der Fehler, mit der Markierung auf (Cel).
Code:

Public Sub Farbe()

    Dim cel

    For Each cel In Range("B5:B507")

        Call Farbindex(cel)

    Next

End Sub

Deine Anpassungen habe ich jetzt alle vorgenommen.

Hast Du noch eine Idee?

Gruß,
Dieter(Drummer)

Poste bitte mal die Datei.

Hallo Onur,

hier die jetzige Datei:
https://www.herber.de/bbs/user/170784.xlsm

Gruß, Dieter(Drummer)

Oder teste vorher das:

Call Farbindex(cel.Address)

Hallo Onur,

geht leider auch nicht und jetzt wird die ganze Zeile "Call Farbindex(cel.Address)" gelb markiert und "Laufzeitfehler 424, Objekt erforderlich"
Wenn nicht geht, dann gehts eben so nicht.

Danle dir für deine Hilfe.

Gruß,
Dieter(Drummer)

Wie gesagt, geht Alles.
Aber dafür brauche ich die Datei, per Ferndiagnose ist das nervenaufreibend.

Guckst du hier:
https://www.herber.de/bbs/user/170785.xlsm

Hallo Onur Danke für Datei,

Eintragungen beginnen hier auch schon bei C statt bei D, wie auch beim Code von Udo. Ansosten werde die Eintragungen gemacht.
Wo liegt der Fehler?

Gruß,
Dieter(Drummer)

Ich dachte, die Zellen in B wären gefärbt.

Guckst du hier:
https://www.herber.de/bbs/user/170786.xlsm

Auf Button klicken.

    Dim x

    x = rng.Address

kann weg - Restmüll aus Testphase.

Hallo Onur,

dieser Zeilen

Dim x

    x = rng.Address

sind in der Datei von dir nicht drin!

Gruß,
Dieter(Drummer)

Umso besser.