Duplikate abwechsend markieren

Forumthread: Duplikate abwechsend markieren

18.09.2022 21:01:24

Bernd

Hallo zusammen,
mit meinem bisherigen VBA-Code werden die Duplikate abwechselnd markiert.
Wie schaffe ich es aber, dass gleiche Inhalte gleich gefärbt sind und dass der Farbwechsel eben nur bei einem abweichenden Projekt zieht?
Die Liste ist immer sortiert.
Wäre nett, wenn mir dabei wer hilft.
Hier noch die Beispielmappe dazu: https://www.herber.de/bbs/user/155250.xlsx


Sub markieren()
'bisheriger VBA-Code:
letztezeile_k = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
izähler = 1
'Farbliches Hervorheben der Vertriebsaufträge mit gleichem Projek
For i = 2 To letztezeile_k
If Cells(i, 1).Value = Cells(i - 1, 1).Value Or Cells(i, 1).Value = Cells(i + 1, 1).Value Then
If izähler > 2 Then izähler = 1
If izähler = 1 Then Cells(i, 1).Interior.ColorIndex = 15
If izähler = 2 Then Cells(i, 1).Interior.ColorIndex = 16
izähler = izähler + 1
End If
Next i
End Sub

danke vorab, Gruß Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Duplikate abwechsend markieren

18.09.2022 22:28:03

Alwin

Hallo Bernd,
anbei folgender Lösungsvorschlag:


Option Explicit
Sub markieren()
Dim SL As Object, i%, j%, k%, l%, m%
Dim arrIn As Variant, arrOut()
k = 2
Set SL = CreateObject("System.Collections.sortedlist")
With Tabelle1
arrIn = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(arrIn)
If arrIn(i, 1)  "" Then _
SL(arrIn(i, 1)) = ""
Next i
ReDim arrOut(1 To SL.Count, 1 To 1)
For i = 1 To SL.Count
arrOut(i, 1) = SL.GetKey(i - 1)
Next i
For i = 1 To UBound(arrOut)
k = k + 1
For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If arrOut(i, 1) = .Cells(j, 1) Then
.Cells(j, 1).Interior.ColorIndex = k
l = l + 1
m = j
End If
Next j
If l = 1 Then
.Cells(m, 1).Interior.ColorIndex = xlNone
End If
l = 0
Next i
End With
End Sub

Ist die Tabelle recht lang, macht es sich u.U. erforderlich den Farbindex zurückzusetzen.
https://www.herber.de/bbs/user/155252.xlsm
Gruß Uwe

AW: Duplikate abwechsend markieren

18.09.2022 22:50:50

Bernd

Hiho,
danke Dir Uwe.
Bei mir bekomm ich einen Laufzeitfehler - '214... - Automatisierungsfehler angezeigt.
Markiert wird gleich die 4. Zeile mit: Set SL = CreateObject("System.Collections.sortedlist")
Ne Ahnung an was das liegt, evtl. ne Bibliothek in VBA?
Gruß Bernd

AW: Duplikate abwechsend markieren

18.09.2022 23:02:41

Alwin

Hallo Bernd,
installiere MS .Net Framework 3.5. Dann sollte es funktionieren.
Gruß Uwe

AW: Duplikate abwechsend markieren

18.09.2022 23:36:43

Bernd

Hallo Uwe,
danke Dir, ja hast recht, zumindest aufm privaten Laptop läufts und prinzipiell ist das Ergebnis auch fast wie gewünscht.
Für den im Geschäft kann ich aktuell nicht testen, da fehlen mir die Adminrechte.
Siehst auch noch ne Möglichkeit, nur zwischen den Fabindex 15 und 16 zu wechseln. Meine Liste ist ja eh sortiert und das reicht dann zur optischen Erkennung.
So ne bunte Liste, wie das jetzt ist, kann ich leider so nicht weitergeben.
Gruss Bernd

AW: Duplikate abwechsend markieren

19.09.2022 08:26:12

Alwin

Hallo Bernd,
was fehlte, um nur die Graustufen 15 und 16 zu benutzen ist doch simples vergleichen. Entweder in k ist 16 erreicht, dann zurück auf 15 oder es wird 1 dazu addiert.
Dann muss nur der Startwert für k auf 14 gesetzt werden. Mehr ist da nicht nötig. Da aber nur die beiden Graustufen benutzt werden, ist wegen der Erkennbarkeit das Sortieren erforderlich. Wenn jede gleiche Gruppe eine eigene Farbe hat, ist es mit dieser Prozedur egal ob sortiert wurde oder nicht.
geändert mit den 2 Graustufen so:


Option Explicit
Sub markieren()
Dim SL As Object, i%, j%, k%, l%, m%
Dim arrIn(), arrOut()
k = 14                                                                      ' Startwert für Farbindex
Set SL = CreateObject("System.Collections.sortedlist")
With Tabelle1
arrIn = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value     ' Alle zu vergleichenden Werte in Array
For i = 1 To UBound(arrIn)                                              ' Ab hier werden sortiert, leere und doppelte entfernt
If arrIn(i, 1)  "" Then _
SL(arrIn(i, 1)) = ""
Next i
ReDim arrOut(1 To SL.Count, 1 To 1)                                     ' dimensioniert das Ausgabe Array für die nun sortierten Unikaten
For i = 1 To SL.Count
arrOut(i, 1) = SL.GetKey(i - 1)
Next i
For i = 1 To UBound(arrOut)                                             ' systematischer Aufruf Werte von arrOut in Schleife i
If k = 16 Then
k = 15
Else
k = k + 1
End If
For j = 2 To .Cells(Rows.Count, 1).End(xlUp).Row                    ' Vergleich Wert arrOut Zellennummer i mit
If arrOut(i, 1) = .Cells(j, 1) Then                             ' Wert Zelle für Zelle des Tabellenblattes in Spalte A
.Cells(j, 1).Interior.ColorIndex = k                        ' Wenn Treffer dann .Interior.ColorIndex = k
l = l + 1                                                   ' l zählt Anzahl der Treffer
m = j
End If
Next j
If l = 1 Then                                                       ' Wenn nur ein Treffer dann Zelle nicht einfärben
.Cells(m, 1).Interior.ColorIndex = xlNone
End If
l = 0                                                               ' für den nächsten Schleifensprung - Treffer auf null setzten
Next i
End With
End Sub

Gruß Uwe

danke

19.09.2022 09:07:09

Bernd

Morgen Uwe's,
danke, und auch danke für die Erklärungen, ich muss mir das heut Abend mal genauer anschaun, aktuell ist mir das ne Nummer zu hoch.
Die Markierung war beim Test jetzt zweifarbig, aber dennoch nicht abwechselnd. Aber ich glaub das lag jetzt bei mir.
Auf jeden Fall nochmals tauschend Dank, mit der anderen Anwort von Uwe funktioniert es ebenso. erledigt :)
Gruß Bernd

AW: Duplikate abwechsend markieren

19.09.2022 08:47:59

UweD

Hallo
hier noch ein Code von mir


Sub markieren()
Dim Z1 As Integer, Sp As Integer, LR As Long, I As Long
Dim Farbe As Integer, F1 As Integer, F2 As Integer
F1 = 15
F2 = 16
Sp = 1 ' Spalte A
Z1 = 2 'erste Datenzeile
LR = Cells(Rows.Count, Sp).End(xlUp).Row
'Reset
Columns(Sp).Interior.ColorIndex = xlNone
Farbe = F1
For I = Z1 To LR
If WorksheetFunction.CountIf(Columns(Sp), Cells(I, Sp)) > 1 Then
Cells(I, Sp).Interior.ColorIndex = Farbe
If Cells(I + 1, Sp) = Cells(I, Sp) Then
Cells(I + 1, Sp).Interior.ColorIndex = Farbe
Else
Farbe = IIf(Farbe = F1, F2, F1)
End If
End If
Next
End Sub

LG UweD

AW: Duplikate abwechsend markieren

19.09.2022 08:59:43

Bernd

Morgen,
perfekt, danke Euch.
Gruß Bernd

AW: Duplikate abwechsend markieren

19.09.2022 10:01:01

Daniel

Hi
Ich würde das ohne Makro lösen
1. in Zelle B1 kommt WAHR oder FALSCH
2. In Zelle B2 kommt die Formel:


=Wenn(Oder(A2=Index(A:A;Zeile()-1);Teilergebnis(3;A2)=0);Index(B:B;Zeile()-1);Nicht(Index(B:B;Zeile() -1)))

3. mache die Färbung über die Bedingte Formatierung mit Der Regelformel:


=$B2

Die Formel in Spalte B könnte man auch einfacher schreiben:


=wenn(A2=A1;B1;Nicht(B1))

Aber in der komplizierten Form funktioniert sie auch, wenn du in der Liste mit den Autofter anwendet, imsortierst, oder Zeilen löschst bzw einfügst. Das alles würde die einfache Formel durcheinander bringen.
Gruß Daniel

Beliebteste Forumthreads (12 Monate)

Forumthread: Duplikate abwechsend markieren

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread