VBATools

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()
'MVP Oskar Shon Dodatki do office www.VBATools.pl
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(zakres As Range)
'MVP Oskar Shon Dodatki do office www.VBATools.pl
Dim Y&, X&, el As Range, Ile&, z&
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
    If z > 56 Then z = 3
    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
End Sub

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

Rys.1 Przykład zastosowania kodu

(c) Shon Oskar – www.VBATools.pl