Live-Forum - Die aktuellen Beiträge
Datum
Titel
07.05.2024 21:30:42
Bilder aus URL in Zelle einfügen - Code anpassen
07.05.2024 20:36:09
xverweis / name Funktion
07.05.2024 20:10:42
Datum z.B. 1897 wird nicht als Datum angezeigt
07.05.2024 19:47:07
Excel Lohnabrechnung anhand 2 Suchkriterien
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1896to1900
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1896to1900
1896to1900
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Duplikate abwechsend markieren

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

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

Betreff
Datum
Anwender
Anzeige
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
Anzeige
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
Anzeige
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
Anzeige
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
Anzeige
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
Anzeige

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige