Zaznaczanie różnymi kolorami powtarzających się wartości

Potrzebujemy, aby makro VBA (niekoniecznie makro, ale jakoś nie wymyśliłem jeszcze innego sposobu) zaznaczalo w kolumnie, przy pomocy róznych kolorów,  powtarzajęce się wartości. Mniej więcej tak:

Moje makro zaznacza powtarzające się wartości mniej więcej w taki właśnie sposób

Gdyby chodziło tylko o zaznaczanie komórek, których wartość się po prostu powtarza skorzystałbym z Formatowania warunkowego. W omawianym przypadku sprawa jest jednak nieco bardziej skomplikowana, ponieważ chciałem, aby różne wartości zaznaczane były różnymi kolorami. Dodatkowo wymyśliłem sobie, że będę mógł łatwo wybrać sobie te kolory.

Mój arkusz pomocniczy (z kolorami) wygląda jakoś tak:

Ustawienia kolorów

Kolorując odpowiednie komórki, dycydujemy jednocześnie o kolorach jakimi zaznaczane będą powtarzające się wartości kolumny z danymi. Makro pobiera po kolei kolory z pokazanych komórek i ustawia je jako kolor tła dla każdej z powtarzających się wartości.  Jeżeli „zabraknie” kolorów (powtarzających się wartości jest więcej niż zdefiniowanych kolorów), będą one (kolory) po prostu pobierane od początku.

Ponieważ chciałem, aby komórki „odświeżały się” po każdorazowym wpisaniu czegoś w komórkę, makro obsługuje zdarzenie onChange arkusza „Dane”.

Moje makro wygląda nastepująco:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngKolory As Range
Dim rngDoPokolorowania As Range
Dim LicznikKolorow As Integer
Dim Licznik As Integer
Dim rngKolumna As Range
Dim rngDaneWypelnione As Range

' zakres komórek z kolorami
Set rngKolory = wksKolory.Range("rngKoloryStart").Resize(wksKolory.Range("settIleKolorow").Value, 1)
' zakres z danymi do pokolorowania
Set rngDoPokolorowania = wksDane.Range(Range("rngDaneStart"), Cells(65535, Range("rngDaneStart").Column).End(xlUp))

' kolumna z danymi
Set rngKolumna = Columns("B")

With wksDane
    Set rngDaneWypelnione = .Range(.Range("rngDaneStart"), .Range("rngDaneStart").Offset(10000).End(xlUp))
End With

If Not Intersect(Target, rngKolumna) Is Nothing Then ' jezeli zmiana w kolumnie z danymi

Application.ScreenUpdating = False ' wylaczam "mruganie" ekranu

' Czyscimy caly obszar danych (ustawiamy w calosci tlo domyslne)

rngDaneWypelnione.Resize(rngDaneWypelnione.Count + 1).Interior.ColorIndex = _
    wksKolory.Range("rngDomyslneTlo").Interior.ColorIndex

LicznikKolorow = 1 ' resetujemy licznik kolorow

With rngDoPokolorowania
   ' pierwsza komorka
   If Application.WorksheetFunction.CountIf(rngDoPokolorowania, .Cells(1).Value) > 1 Then
      .Cells(1).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex
      LicznikKolorow = LicznikKolorow + 1
      If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1
   End If

    'Jezeli jest wiecej niz jedna komorka
    If rngDaneWypelnione.Count > 1 Then
        ' to dla kolejnych komorek
        For Licznik = 2 To .Count
            If Application.WorksheetFunction.CountIf(rngDoPokolorowania, _
                                                    .Cells(Licznik).Value) > 1 Then
                If Application.WorksheetFunction.CountIf(Range("rngDaneStart").Resize(Licznik - 1), .Cells(Licznik).Value) > 0 Then
                    .Cells(Licznik).Interior.ColorIndex = _
                    rngDaneWypelnione.Find(what:=.Cells(Licznik).Value, after:=.Cells(Licznik), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex
                Else
                    .Cells(Licznik).Interior.ColorIndex = rngKolory.Cells(LicznikKolorow).Interior.ColorIndex
                    LicznikKolorow = LicznikKolorow + 1
                If LicznikKolorow > rngKolory.Count Then LicznikKolorow = 1
                End If
            End If
       Next Licznik
    End If
End With
Application.ScreenUpdating = True
End If

End Sub

Oczywiście nie jest to rozwiązanie idealne, ale w prostych przypadkach spełnia swoją rolę. Poza tym może służyć za inspirację i punkt wyjścia do bardziej kompleksowych rozwiązań. Poniżej, jak zwykle, do ściągnięcia plik z przykładem.

Marcin

Tagged as: formatowanie warunkowe, Makro, VBA