Makro um doppelte Werte fablich zu hinterlegen

...komplette Frage anzeigen

6 Antworten

Hier ein Code, der wechselseitig die gleichen Zellen färbt:

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim dblColorFlipFlop As Long

dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
            J = J + 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
    End If
Next I
End Sub

Achtung, bis Excel 2003 kann man bei RGB nur bestimmte Werte benutzen. Erst ab Excel 2010 ist alles möglich.

Statt 
 Interior.Color = RGB( …) kann man auch sagen 
 Interior.Colorindex  = 16

Ganzzahlig, von 1 bis 57  möglich.

Zum Ermitteln der möglichen Farben noch zwei Codes:

Sub srtFarbTest1()
Dim I As Integer
For I = 255 To 5 Step -1
    Cells(256 - I, 1) = I
    Cells(256 - I, 2).Interior.Color = RGB(I, I, I)
Next I
End Sub

Und Code drei

Sub srtFarbTest2()
Dim I As Integer
For I = 1 To 57
    Cells(I, 3) = I
    Cells(I, 4).Interior.ColorIndex = I
Next I

End Sub

Hoffe es hilft

So ganz, wie gewollt, funktioniert es noch nicht...
... sind mehr als 2 gleiche Einträge vorhanden, sind diese nicht mehr gleichfarbig.

Änderungvorschlag:
Beim FlipFlop schalten: Do While Cells(I + J) = Cells(I, 1)
die Spalte mit angeben: Do While Cells(I + J,1) = Cells(I, 1)

und

nach End With in neuer Zeile einfügen: I = I + J - 1
(damit wird der schon geprüfte und gefärbte Bereich übersprungen)

Gruß aus Berlin

0
@Britzcontrol

ACHTUNG: wenn letzte Zelle einen Doppeleintrag enthält, gibts einen Fehler.
Also die letzte Zelle nur mit Einzelwert testen.

0
@Britzcontrol

Hallo PauleVBA und Britzcontrol,

danke für eure Vorschläge, ich habe das jetzt mal so übernommen, wenn ich auf ausführen drücke, gibt mir Excel eine Fehlermeldung aus "Fehler beim Kompilieren If-Block ohne End If". Woran kann das liegen?

Ich habe versuch den Code mit Strg-K zu kopieren aber er wird hier immer nur als Text eingefügt.

0
@Excelfrager84

Das mit dem End If kann ich dir auch nicht erklären. Wenn du den obigen Code so übernommen hast, kann es diese Fehlermeldung nicht geben, es sei denn, du hast diesen Code in bereits bestehenden Code eingefügt.

  1. Anmelden
  2. den Code oben markieren
  3. Im VBA-Editor (Alt F11) einfach nur einfügen.

Und was den Code für das Board angeht:

  1. Code im VBA-Edirtor markieren und kopieren
  2. Kopiertes hier im Eingabefeld einfügen
  3. Diesen Text im Eingabefeld dann nochmals markieren
  4. jetzt Strg K drücken oder fünfte Schaltfläche über Textfeld anklicken
0
@PauleVBA

Hallo PauleVBA und Britzcontrol,

zusammen mit der Anmerkung von Britzcontrol funktioniert der Code von PauleVBA super, es ist jedoch so, dass immer nur zwei Zellen farblich hinterlegt werden, in meinem Dokument, kann es aber auch sein das es drei oder vier Zeilen farblich hinterlegt werden müssen. Kann man den Code so anpassen. Durch den Code werden ja auch nur die Zellen farblich hinterlegt, kann man das so erweitern, dass auch die ganze Zeile farblich hinterlegt wird, wie es mit den Code zur Bedingten Formatierung durchgeführt wurde?

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim dblColorFlipFlop As Long

dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("$A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J, 1) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
           I = I + J - 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
       
    End If
Next I
End Sub
0
@Excelfrager84

Nur mal schnell zu dem Vorhaben "ganze Zeile farblich zu hinterlegen".

Davon kann ich nur abraten, weil dann je "Färbung", also bis Spalte XFD, 16.384 Zellen formatiert sind. Das bläht alles auf.

Besser ist, den zu färbenden Bereich zu beschränken.

Gruß aus Berlin

0
@Britzcontrol

so, jetzt aber ...

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim n As Long
Dim dblColorFlipFlop As Long

n = 3 ' Anzahl der zu markierenden Spalten
dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("$A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J, 1) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
        J = J + 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
    I = I + J - 1
    End If
    
Next I
End Sub

Alle Anforderungen erfüllt ! (???)

Gruß aus Berlin

1

Nicht genau wie von dir beschrieben, aber ähnlich kannst du es mit der bedingten Formatierung erreichen. Leg einfach zwei Regeln mit folgenden Formeln an:

  1. =UND(ODER(A2=A3;A2=A1);A2<>"")
  2. =UND(A2<>A1;A2=A3)

Der ersten Regel gibst du als Format eine Hintergrundfarbe, der 2. einen oberen Rahmen.

Beide Regeln werden angewendet auf =$A:$A.

Hallo Sapex22,

danke für deine Antwort, auf diesem Wege erhalte ich nicht das gewünschte Resultat. Es werde nur bestandeteile von Zeile grau hinterlegt, jedoch nicht die gesamte Zeile.

0
@Excelfrager84

Genau so hattest du aber deine Frage gestellt.
Naja, dann modifizierst du das Ganze halt:

=UND(ODER($A2=$A3;$A2=$A1);$A2<>"")
=UND($A2<>$A1;$A2=$A3)

und wendest die Regel an auf =$A:$X.

0

das machst du mit einem flip-flop: die beiden farbwerte legst du in ein array ab, mit dem index ff greifst du darauf zu (ff=1 oder 2). bei jeder zuteilung einer farbe schaltest du um: ff=3-ff .

@Maximilianus7: das mit dem Flip-Flop ist ja ganz nett, trifft aber nicht des Pudels Kern: 5 wäre hell, 6 dunkel, 7 hell usw. es soll aber 5 bis 7 hell und 8 bis dunkel werden.

0

Ohne deinen Code, der die Färbung durchführt kann ich hier schlecht Tipps geben. Und anderen wird es genauso gehen.

Bitte achte darauf, dass Code auch als Code markiert wird:

Code-Text mit der Maus markieren und Strg-K drücken oder die 5. Schaltfläche oben über dem Editor.

Hallo Paule VBA und maximilianus7,

danke für eure Antworten, den Code habe ich hier mal eingefügt, maximilianus7, mit Flip-Flop und arrays kenne ich mich leider überhaupt nicht aus, gibt es dazu irgendow infos/trainings?

Code: Selection.FormatConditions(1).StopIfTrue = False Range("A11:S600").Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _ "=ZÄHLENWENN($A$1:$S$600;$A11)>1" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249946592608417 End With Selection.FormatConditions(1).StopIfTrue = False

bitte den code mit ctrl-k formatieren (wie beim kopieren, nur ctrl-k statt ctrl-c)

du kennst dich nicht mit arrays aus dafür versteh ich deinen code nicht. ist der aus einer makroaufzeichnung entstanden? kernstück scheint mir die formel zu sein (zählewenn) aber damit ist auch grenze erreicht was du mit formeln erreichen kannst.

ich hätte da eher an eine schleife über die spalte A gedacht mit gruppenwechsel über den inhalt. aber da du dich mit programmieren nicht auskennst, müsstest du jemand finden, der das für dich macht.

0

Für mehrere Zellen änderst du den Code:

.Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)

wird

.Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(171, 171, 171)

Wobei du n durch die Anzahl der Spalten ersetzt, die gefärnt werden sollen

Was möchtest Du wissen?