Doppelte Werte mit gleiche Farbe löschen

[FerdiFuchs99]

Hallo,
ich habe aktuell das Problem, dass ich viele Doppelte Werte habe und diese in zwei verschiedenen Farben vorhanden sind. Nun sollen jedoch NUR die doppelten entfernt werden, die ausschließlich gelb sind. Wenn nur eine der doppelten rot sind, sollen alle bestehen bleiben. Um das besser zu sehen, habe ich ein Beispiel als Bild hochgeladen.
Ich bin mit VBA zu dem Punkt gekommen, alle gelben doppelten zu löschen, aber ich finde keine Möglichkeit die Bedingung mit rot einfließen zu lassen.

Ich hoffe einer kann mir helfen. Ich wäre sehr dankbar.
anderes Forum

Ergänzung (9. Februar 2023)

Mein bisheriger Code

Sub DuplikateNurGelb()
Dim toDel(), i As Long
Dim RNG As Range, Cell As Long
Dim sheet As Worksheet
Set sheet = Worksheets("Tabelle1")
lastRow = sheet.Cells(sheet.Rows.Count, 1).End(xlUp).Row

Set RNG = Range("h1:h" & lastRow)

For Cell = 1 To RNG.Cells.Count
If Application.CountIf(RNG, RNG(Cell)) > 1 Then
ReDim Preserve toDel(i)
toDel(i) = RNG(Cell).Address
i = i + 1
End If
Next

For i = UBound(toDel) To LBound(toDel) Step -1
If Range(toDel(i)).Cells.Interior.ColorIndex = 6 Then

RowToDel = Range(toDel(i)).Cells.Row
Rows(RowToDel).EntireRow.Delete
End If
Next i
End Sub

 

[sh.]

habe mal bissle rumgetestet

Sub DeleteDuplicatesWithYellowBackground()

Dim lngLastRow As Long
Dim rng As Range
Dim cell As Range
Dim blnDeleteRow As Boolean

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set rng = Range("A1:A" & lngLastRow)

For Each cell In rng

If cell.Interior.Color = RGB(255, 255, 0) Then

blnDeleteRow = True

If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), cell.Value) > 1 Then

If WorksheetFunction.CountIf(Range("A1:A" & cell.Row), cell.Value) > 1 Then

For i = 1 To lngLastRow

If Cells(i, 1).Value = cell.Value And Cells(i, 1).Interior.Color = RGB(255, 0, 0) Then

blnDeleteRow = False
Exit For

End If

Next i

End If

End If

If blnDeleteRow = True Then cell.EntireRow.Delete

End If

Next cell

End Sub

 

[floq0r]

Du kannst Duplikate mit ZÄHLENWENN() feststellen, dann kannst du nach Farbe sortieren und für Zeilen mit gelben Zellen einen extra Wert in einer Spalte setzen, dann nach dieser Spalte filtern und alle Zeilen entfernen - fertig.

 

[FerdiFuchs99]

habe mal bissle rumgetestet

Sub DeleteDuplicatesWithYellowBackground()

Dim lngLastRow As Long
Dim rng As Range
Dim cell As Range
Dim blnDeleteRow As Boolean

lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row

Set rng = Range("A1:A" & lngLastRow)

For Each cell In rng

If cell.Interior.Color = RGB(255, 255, 0) Then

blnDeleteRow = True

If WorksheetFunction.CountIf(Range("A1:A" & lngLastRow), cell.Value) > 1 Then

If WorksheetFunction.CountIf(Range("A1:A" & cell.Row), cell.Value) > 1 Then

For i = 1 To lngLastRow

If Cells(i, 1).Value = cell.Value And Cells(i, 1).Interior.Color = RGB(255, 0, 0) Then

blnDeleteRow = False
Exit For

End If

Next i

End If

End If

If blnDeleteRow = True Then cell.EntireRow.Delete

End If

Next cell

End Sub

Super es klappt.
Nur es wird nicht komplett gelöscht sondern erst 2 und dann jeweils 1 pro "Run". Außerdem soll der Bezug in der H spalte sein und sobald ich die Range auf H ändere, funktioniert der Code nicht mehr. Wie kann das sein.
Trotzdem vielen Dank erstmal!!!