Mit VBA Spalten auf doppelte Werte prüfen ...
16.06.2016 18:16:16
Max
ich möchte ein Excel Tabellenblatt Spaltenweise mittels VBA Code auf doppelte Werte überprüfen. Sobald was eingetippt wird bzw.aus einem Drop Down Menü ausgewählt wird und doppelt auftritt soll es farbig markiert werden.
Bisher habe ich es über die Bedingte Formatierung/ Doppelte Werte farbig markieren gemacht. Ist zwar ganz gut und schön und funktioniert auch nur wird es langsam unübersichtlich und einen unerklärlichen Bug gibts auch schon ....
Es gibt wohl auch eine Formelbasierte Lösung, die möchte ich aber nicht da in dem Tabellenblatt schon mehrere Formeln drin sind und ich auch nicht so recht weiß wohin damit. Außerdem gibts mehrere Benutzer die mit "copy & paste" + Enft! regelmäßig für Chaos sorgen.
So nun hab ich von VBA net wirklich Ahnung und das wenige ist aus dem iNet zusammenkopiert und solange irgendwie bearbeitet worden bis es irgendwie funktioniert ;)
Hier ist mal der VBA Code zum o.g. Problem (allerdings nicht vollständig)
Leider ist das ganze langsam und umständlich, aber es funktioniert!
Ich suche nun einen schnelleren /besseren Code, der sich auch leicht ergänzen lässt und den ich vielleicht auch nachvollziehen kann.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range
For Each rngCell In Range("D16:D56")
If WorksheetFunction.CountIf(Range("D16:D56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("K16:K56")
If WorksheetFunction.CountIf(Range("K16:K56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("O16:O56")
If WorksheetFunction.CountIf(Range("O16:O56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("S16:S56")
If WorksheetFunction.CountIf(Range("S16:S56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("W16:W56")
If WorksheetFunction.CountIf(Range("W16:W56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AA16:AA56")
If WorksheetFunction.CountIf(Range("AA16:AA56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AE16:AE56")
If WorksheetFunction.CountIf(Range("AE16:AE56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AI16:AI56")
If WorksheetFunction.CountIf(Range("AI16:AI56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AM16:AM56")
If WorksheetFunction.CountIf(Range("AM16:AM56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AQ16:AQ56")
If WorksheetFunction.CountIf(Range("AQ16:AQ56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
For Each rngCell In Range("AU16:AU56")
If WorksheetFunction.CountIf(Range("AU16:AU56"), rngCell.Value) > 1 Then
rngCell.Interior.Color = RGB(240, 175, 180) 'RGB Farbwert - Flamingo1
Else: rngCell.Interior.ColorIndex = xlNone
End If
Next rngCell
If Target.Count Then
For Each rngCell In Range("K16:AU56")
Select Case rngCell.Value
Case "12"
rngCell.Interior.Color = RGB(186, 219, 244) 'RGB Farbwert - Wolkenblau
End Select
Next rngCell
End If
End Sub