Makro um doppelte Werte fablich zu hinterlegen

Hallo, ich habe ein Makro, welches eine Excel Tabelle nach bestimmten Vorgaben formatiert. Dabei durchsucht es Spalte A nach doppelt vorkommenden Sachnummern und hinterlegt die gesamte Zeile grau wenn denn solche auftauchen.

Es kann aber vorkommen, dass nach doppelt vorkommenden Sachnummern direkt wieder doppelte Sachnummern angezeigt werden. Jetztz suche ich nach einer Möglichkeit, diese dann in einer anderen Farbe zu hinterlegen. Wie unten beispielhaft dargestellt, würden die Zeilen A5:A9 grau hinterlegt. Das Ziel wäre jetzt, dass Zeilen A5:A7dunkelgrau und A8:A9 hellgrau hinterlegt werden. Ich hab keine Idee, wie man so etwas anstellen könnte.

1. Spalte A
2. V
3. L
4. O
5. H
6. H
7. H
8. S
9. S

Danke schon mal an alle die sich die Zeit nehmen zu Antworten

Answer 1

[PauleVBA]

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

Comments

[Britzcontrol]

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

[Britzcontrol]

@Britzcontrol

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

[Excelfrager84]

@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.

[PauleVBA]

@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

[Excelfrager84]

@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

[Britzcontrol]

@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

[Britzcontrol]

@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

[Excelfrager84]

@Britzcontrol

Vielen Dank Britzcontrol, jetzt funktioniert es genauso wie gewollt.

Answer 2

[Sapex22]

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.

Comments

[Excelfrager84]

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.

[Sapex22]

@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.

Answer 3

[PauleVBA]

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

Answer 4

[maximilianus7]

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 .

Comments

[PauleVBA]

@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.

Answer 5

[PauleVBA]

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.