Přejít k hlavnímu obsahu

Jak zvýraznit duplicitní hodnoty v různých barvách v aplikaci Excel?

doc duplikáty různých barev 1

V aplikaci Excel můžeme snadno zvýraznit duplicitní hodnoty ve sloupci jednou barvou pomocí Podmíněné formátování, ale někdy musíme zvýraznit duplicitní hodnoty v různých barvách, abychom rychle a snadno rozpoznali duplikáty, jak ukazuje následující snímek obrazovky. Jak byste mohli vyřešit tento úkol v aplikaci Excel?

Zvýrazněte duplicitní hodnoty ve sloupci s různými barvami pomocí kódu VBA


šipka modrá pravá bublina Zvýrazněte duplicitní hodnoty ve sloupci s různými barvami pomocí kódu VBA

Ve skutečnosti neexistuje žádný přímý způsob, jak tuto práci dokončit v aplikaci Excel, ale níže uvedený kód VBA vám může pomoci, postupujte takto:

1. Vyberte sloupec hodnot, který chcete zvýraznit duplikáty s rozdílnými barvami, a poté podržte ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. klikněte Vložit > Modula vložte následující kód do Modul Okno.

Kód VBA: Zvýrazněte duplicitní hodnoty v různých barvách:

Sub ColorCompanyDuplicates()
'Updateby Extendoffice
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection
    For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
        xCIndex = xCIndex + 1
        Set xCellPre = xCol(xCell.Text)
        If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
        xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
        MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
        Exit Sub
      End If
      On Error GoTo 0
    Next
End Sub

3. A pak stiskněte F5 klíč ke spuštění tohoto kódu a okno s výzvou vám připomene, abyste vybrali rozsah dat, který chcete zvýraznit duplicitní hodnoty, viz screenshot:

doc duplikáty různých barev 2

4. Pak klikněte na tlačítko OK tlačítko, všechny duplicitní hodnoty byly zvýrazněny různými barvami, viz screenshot:

doc duplikáty různých barev 1

Nejlepší nástroje pro produktivitu v kanceláři

Populární funkce: Najít, zvýraznit nebo identifikovat duplikáty   |  Odstranit prázdné řádky   |  Kombinujte sloupce nebo buňky bez ztráty dat   |   Kolo bez vzorce ...
Super vyhledávání: Více kritérií VLookup    VLookup s více hodnotami  |   VLookup na více listech   |   Fuzzy vyhledávání ....
Pokročilý rozevírací seznam: Rychle vytvořte rozevírací seznam   |  Závislý rozbalovací seznam   |  Vícenásobný výběr rozevíracího seznamu ....
Správce sloupců: Přidejte konkrétní počet sloupců  |  Přesunout sloupce  |  Přepnout stav viditelnosti skrytých sloupců  |  Porovnejte rozsahy a sloupce ...
Doporučené funkce: Zaměření mřížky   |  Návrhové zobrazení   |   Velký Formula Bar    Správce sešitů a listů   |  Knihovna zdrojů (Automatický text)   |  Výběr data   |  Zkombinujte pracovní listy   |  Šifrovat/dešifrovat buňky    Odesílat e-maily podle seznamu   |  Super filtr   |   Speciální filtr (filtr tučné/kurzíva/přeškrtnuté...) ...
Top 15 sad nástrojů12 Text Tools (doplnit text, Odebrat znaky, ...)   |   50+ Graf Typ nemovitosti (Ganttův diagram, ...)   |   40+ Praktické Vzorce (Vypočítejte věk na základě narozenin, ...)   |   19 Vložení Tools (Vložte QR kód, Vložit obrázek z cesty, ...)   |   12 Konverze Tools (Čísla na slova, Přepočet měny, ...)   |   7 Sloučit a rozdělit Tools (Pokročilé kombinování řádků, Rozdělit buňky, ...)   |   ... a více

Rozšiřte své dovednosti Excel pomocí Kutools pro Excel a zažijte efektivitu jako nikdy předtím. Kutools for Excel nabízí více než 300 pokročilých funkcí pro zvýšení produktivity a úsporu času.  Kliknutím sem získáte funkci, kterou nejvíce potřebujete...

karta kte 201905


Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
Comments (95)
Rated 5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Very helpful! Thanks a lot for sharing :-)
This comment was minimized by the moderator on the site
it only applies to 5 duplicates then don't work
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot...
Rated 5 out of 5
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot..
Rated 5 out of 5
This comment was minimized by the moderator on the site
Hi, thank you for this, I am having an issue though.

When I hit F5 it brings up the macros screen instead of a prompt to select the column data selection so all I could see was to hit "run" however I then get an error message to say;

Compile error:

Ecpected: end of statement.

Can you help please?
This comment was minimized by the moderator on the site
Funcionó perfecto. Muchas gracias.
This comment was minimized by the moderator on the site
perfect, i love u
This comment was minimized by the moderator on the site
this code left some duplicates with no fill (often those with one pair) can u check the code why and give me new please? ps. document have 6000+ positions and sometimes 5 to 10 duplicates 
This comment was minimized by the moderator on the site
Hello, hayyi,Yes, as you said, the code in this article does not work well when there are lots of duplicate cells, in this case, you can try the below code:<div data-tag="code">Sub Colorduplicates()
On Error Resume Next
c = InputBox("Please enter the column heading you want to highlight cells", , "A")
r = Cells(65536, c).End(xlUp).Row
arr = Cells(1, c).Resize(r, 1).Value
Set d = CreateObject("scripting.dictionary")
For I = 1 To r
d(arr(I, 1)) = d(arr(I, 1)) + 1
Next I
ks = d.keys
its = d.items
For I = 0 To UBound(ks)
If its(I) > 1 Then
d.Item(ks(I)) = RGB(Int(Rnd * 99) + 99, Int(Rnd * 99) + 99, Int(Rnd * 99) + 99)
Else
d.Item(ks(I)) = xlNone
End If
Next
t = Cells(1, 256).End(xlToLeft).Column
For I = 1 To r
Cells(I, 1).Resize(1, t).Interior.Color = d(arr(I, 1))
Next
Set d = Nothing
End SubIf this code can help you, please let me know. Thank you!
This comment was minimized by the moderator on the site
Excel crashes everytime I attempt running one of your codes:
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.EntireRow.Interior.ColorIndex = xCIndex
xCell.EntireRow.Interior.ColorIndex = xCellPre.EntireRow.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub

I have tried running in safe mode and It still crashes. I'm in the most recent version of excel. Any suggestions?
This comment was minimized by the moderator on the site
Hi, is there any way to have this code ignore empty cells? When I put in the code it highlighted all of the empty cells and I need them to be blank.Thank you!
This comment was minimized by the moderator on the site
Hi, Sadie,To ignore the empty cells, please apply the below code:<div data-tag="code">Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
End If
Next
End SubPlease try, hope it can help you!
This comment was minimized by the moderator on the site
Hello,
I there a way to highlight opposite instead of duplicate and ignore empty cells?
Thanks
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations