V poslednom riešení som uvažoval s maximálnym počtom farbičiek 50, čo ale nie vždy musí postačovať, v iných prípadoch je to zas zbytočne mnoho. V novej verzii kódu je spočítaný potrebný počet farieb a až na základe neho stanovená veľkosť poľa clrArr. Tento kód už asi občas použijem i ja sám pre svoje vlastné potreby. Pokiaĺ bude potrebných viac než 256 farieb, tak premenné typu Byte je treba predeklarovať na typ Integer prípadne Long:Sub ColorDupsNew()
Dim i As Byte, k As Byte, clrVal As Long, clrValOccupied As Boolean, myRng As Range, cell As Range, j As Byte
Set myRng = Selection
'urcenie nutneho poctu farieb na zaklade poctu duplicit
j = Evaluate("SUM(1/COUNTIF(" & myRng.Address & ",""""&" & myRng.Address & ")) - SUM(--(COUNTIF(" & myRng.Address & ", " & myRng.Address & ")=1))")
ReDim clrArr(1 To j) As Long
'vytvorenie unikatnej kolekcie farieb
For k = 1 To j
clrValOccupied = False
clrVal = RGB(WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255))
For i = 1 To k
If clrArr(i) = clrVal Then
clrValOccupied = True
Exit For
End If
Next i
If clrValOccupied = False Then
clrArr(k) = clrVal
Else: k = k - 1
End If
Next k
myRng.Interior.Pattern = xlNone 'vymaze farby
k = 0
For Each cell In myRng.Cells
If WorksheetFunction.CountIf(myRng, cell) > 1 Then ' existuju duplicity
If WorksheetFunction.Match(cell, myRng, 0) = cell.Row - myRng.Cells(1, 1).Row + 1 Then 'prvy vyskyt duplicity
k = k + 1
cell.Interior.Color = clrArr(k)
Else: cell.Interior.Color = myRng.Cells(WorksheetFunction.Match(cell, myRng, 0), 1).Interior.Color
End If
End If
Next cell
End Subcitovat
Dim i As Byte, k As Byte, clrVal As Long, clrValOccupied As Boolean, myRng As Range, cell As Range, j As Byte
Set myRng = Selection
'urcenie nutneho poctu farieb na zaklade poctu duplicit
j = Evaluate("SUM(1/COUNTIF(" & myRng.Address & ",""""&" & myRng.Address & ")) - SUM(--(COUNTIF(" & myRng.Address & ", " & myRng.Address & ")=1))")
ReDim clrArr(1 To j) As Long
'vytvorenie unikatnej kolekcie farieb
For k = 1 To j
clrValOccupied = False
clrVal = RGB(WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255), WorksheetFunction.RandBetween(0, 255))
For i = 1 To k
If clrArr(i) = clrVal Then
clrValOccupied = True
Exit For
End If
Next i
If clrValOccupied = False Then
clrArr(k) = clrVal
Else: k = k - 1
End If
Next k
myRng.Interior.Pattern = xlNone 'vymaze farby
k = 0
For Each cell In myRng.Cells
If WorksheetFunction.CountIf(myRng, cell) > 1 Then ' existuju duplicity
If WorksheetFunction.Match(cell, myRng, 0) = cell.Row - myRng.Cells(1, 1).Row + 1 Then 'prvy vyskyt duplicity
k = k + 1
cell.Interior.Color = clrArr(k)
Else: cell.Interior.Color = myRng.Cells(WorksheetFunction.Match(cell, myRng, 0), 1).Interior.Color
End If
End If
Next cell
End Subcitovat
RSS nejnovější články