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

by Marcin

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:

Zaznaczanie powtarzających się wartości w Excelu

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:

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

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.

Download

Marcin

{ 5 comments… read them below or add one }

Ola

gdzie jest ten link do sciągnięcia z przykładem? prosze o szybka odp…

marcin

Musisz się zarejestrować, jak byk jest napisane.

Tomek

Marcin prosiłbym cię o pomoc w czymś taki dałbyś radę może (link poniżej)

http://www.elektroda.pl/rtvforum/viewtopic.php?p=8360896#8360896

Krzysiek

A czemu tak mało porad video?
Na yt jest tego pełno np. http://www.youtube.com/watch?v=iFuCsaj6WqU

fiedorek

interesuje mnie jak z kilku tysiecy wpisow np nr telefonu wyselekcjonowac te powtarzajace sie ?

Leave a Comment

Previous post:

Next post: