VBA Tools

W większości przypadków z duplikatami mamy do czynienia w

bazach danych, które to są agregowane w tabelach przestawnych lub są one importowane jako tabela rekordów. Często też chcemy się ich pozbyć, o ile duplikat nic nie wnosi do obliczenia wartości jakie przedstawiają rekordy. Tym razem jednak chodzi o przydzielenie kolorów do każdego duplikatu (wielowystepowania) na zaznaczonym wcześniej obszarze. Procedura jest ograniczona do 56 podstawowej gamy kolorów arkuszowych (-2 dla białego i czarnego).

Sub zaznacz_duplikaty_kolorami_uwzg_przerwy()
Dim y&, x&, el As Range, zakres As Range, ile&
Set zakres = Selection
ile = zakres.Cells.Count
ReDim baza(1 To ile)
For Each el In zakres
x = x + 1
 el.Interior.ColorIndex = 0
 If Len(el.Value) = 0 Then baza(x) = "": GoTo przeskocz
 For y = 1 To UBound(baza)
 If baza(y) = el.Value Then
 el.Interior.ColorIndex = y + 2
 Cells(y, 1).Interior.ColorIndex = y + 2
 Exit For
 End If
 Next y
 baza(x) = el.Value
przeskocz:
Next el
Set zakres = Nothing
End Sub

Powyżej wynik na reprezentacyjnej próbce danych osadzonych w kolumnie „A”:

Sub zaznacz_duplikaty_kolorami_dla_obszarow()
Dim y&, x&, el As Range, ile&, zakres As Range, z&
Set zakres = Selection
With Application
 .ScreenUpdating = False
ile = .WorksheetFunction.CountA(zakres.Cells)
End With
ReDim baza(1 To 2, 1 To ile)
zakres.Cells.Interior.ColorIndex = 0
For Each el In zakres
 If Len(el.Value) = 0 Then GoTo przeskocz
 For y = 1 To x
 If baza(1, y) = el.Value Then
 If y >= 56 Then z = y + 2 - 56 * (y \ 56) Else z = y + 2
 el.Interior.ColorIndex = z
 Range(baza(2, y)).Interior.ColorIndex = z
 GoTo przeskocz
 End If
 Next y
x = x + 1: baza(1, x) = el.Value: baza(2, x) = el.Address
przeskocz:
Next el
Application.ScreenUpdating = True
Set zakres = Nothing
End Sub

Wynik dla obszarów bez względu na jego położenie z zapętleniem ograniczenia 56 kolorów (-2).

(c) Shon Oskar – www.VBATools.pl

Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.