Gå til hovedindhold

Hvordan fremhæves duplikatværdier i forskellige farver i Excel?

Forfatter: Xiaoyang Sidst ændret: 2020-12-25
doc forskellige farver duplikater 1

I Excel kan vi nemt fremhæve de duplikerede værdier i en kolonne med en farve ved hjælp af Betinget formatering, men nogle gange er vi nødt til at fremhæve duplikatværdierne i forskellige farver for at genkende duplikaterne hurtigt og nemt som det viste skærmbillede. Hvordan kunne du løse denne opgave i Excel?

Fremhæv duplikatværdier i en kolonne med forskellige farver ved hjælp af VBA-kode


pil blå højre boble Fremhæv duplikatværdier i en kolonne med forskellige farver ved hjælp af VBA-kode

Faktisk er der ingen direkte måde for os at afslutte dette job i Excel, men nedenstående VBA-kode kan hjælpe dig, skal du gøre som følger:

1. Vælg kolonnen med værdier, som du vil fremhæve duplikater med forskellige farver, og hold derefter nede ALT + F11 nøgler til at åbne Microsoft Visual Basic til applikationer vindue.

2. Klik indsatte > Moduler, og indsæt følgende kode i Moduler Vindue.

VBA-kode: Fremhæv duplikatværdier i forskellige farver:

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. Og tryk derefter på F5 nøgle til at køre denne kode, og et promptfelt vil minde dig om at vælge det dataområde, som du vil fremhæve duplikatværdierne, se skærmbillede:

doc forskellige farver duplikater 2

4. Klik derefter på OK knap, alle duplikatværdier er fremhævet i forskellige farver, se skærmbillede:

doc forskellige farver duplikater 1

Bedste kontorproduktivitetsværktøjer

🤖 Kutools AI Aide: Revolutionér dataanalyse baseret på: Intelligent udførelse   |  Generer kode  |  Opret brugerdefinerede formler  |  Analyser data og generer diagrammer  |  Aktiver Kutools funktioner...
Populære funktioner: Find, fremhæv eller identificer dubletter   |  Slet tomme rækker   |  Kombiner kolonner eller celler uden at miste data   |   Runde uden formel ...
Super opslag: VLookup med flere kriterier    Multiple Value VLookup  |   VOpslag på tværs af flere ark   |   Fuzzy Lookup ....
Avanceret rulleliste: Opret hurtigt rulleliste   |  Afhængig rulleliste   |  Multivælg rulleliste ....
Column Manager: Tilføj et bestemt antal kolonner  |  Flyt kolonner  |  Skift synlighedsstatus for skjulte kolonner  |  Sammenlign områder og kolonner ...
Fremhævede funktioner: Grid fokus   |  Designvisning   |   Stor Formel Bar    Arbejdsbog & Ark Manager   |  Ressourcebibliotek (Autotekst)   |  Datovælger   |  Kombiner regneark   |  Krypter/Dekrypter celler    Send e-mails efter liste   |  Superfilter   |   Specielt filter (filter fed/kursiv/gennemstreget...) ...
Top 15 værktøjssæt12 tekst Værktøjer (tilføje tekst, Fjern tegn, ...)   |   50 + Chart Typer (Gantt kort, ...)   |   40+ Praktisk formler (Beregn alder baseret på fødselsdag, ...)   |   19 Indsættelse Værktøjer (Indsæt QR-kode, Indsæt billede fra sti, ...)   |   12 Konvertering Værktøjer (Tal til ord, Valutaomregning, ...)   |   7 Flet og del Værktøjer (Avancerede kombinere rækker, Opdel celler, ...)   |   ... og mere

Overlad dine Excel-færdigheder med Kutools til Excel, og oplev effektivitet som aldrig før. Kutools til Excel tilbyder over 300 avancerede funktioner for at øge produktiviteten og spare tid.  Klik her for at få den funktion, du har mest brug for...

Beskrivelse


Fanen Office bringer en grænseflade til et kontor med Office, og gør dit arbejde meget lettere

  • Aktiver redigering og læsning af faner i Word, Excel, PowerPoint, Publisher, Access, Visio og Project.
  • Åbn og opret flere dokumenter i nye faner i det samme vindue snarere end i nye vinduer.
  • Øger din produktivitet med 50 % og reducerer hundredvis af museklik for dig hver dag!
Comments (98)
Rated 5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Thanks for the code but this code has a limitation on the amount of highlighted pairs. For example if your table has more then several hundreds duplicate pairs it does not work. Besides in my case it also highlights the cells that are empty. So I have not found any working code so i made another code by myself and it works perfectly with any range. Test please guys:

Sub DuplicatesColoring()
Dim rng As Range
Dim objDictDupes As Object
Dim cell As Range
Dim I As Integer

' Prompt user to select the range
On Error Resume Next
Set rng = Application.InputBox("Please select the range:", Type:=8)
On Error GoTo 0

' Check if a range was selected
If rng Is Nothing Then
MsgBox "No range selected. Exiting the macro.", vbExclamation
Exit Sub
End If

Set objDictDupes = CreateObject("Scripting.Dictionary")
rng.Interior.ColorIndex = -4142
I = 3

For Each cell In rng
If cell.Value <> "" Then ' Check if cell is not empty
If objDictDupes.Exists(cell.Value) Then
If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
Else
objDictDupes.Item(cell.Value).Interior.ColorIndex = I
cell.Interior.ColorIndex = I
I = I + 1
End If
Else
objDictDupes.Add cell.Value, cell
End If
End If
Next cell
End Sub
This comment was minimized by the moderator on the site
Hallo. Thats very helpfull. But it seems only working when you do not have much cells.
Is there a way to get it running with more then 100 cells an 15 rows

Thank you in advanced.

Kind regards
Volker
This comment was minimized by the moderator on the site
I had the same problem and besides it was highlighting blank cells. I have made my own code and works perfectly:

Sub DuplicatesColoring()
Dim rng As Range
Dim objDictDupes As Object
Dim cell As Range
Dim I As Integer

' Prompt user to select the range
On Error Resume Next
Set rng = Application.InputBox("Please select the range:", Type:=8)
On Error GoTo 0

' Check if a range was selected
If rng Is Nothing Then
MsgBox "No range selected. Exiting the macro.", vbExclamation
Exit Sub
End If

Set objDictDupes = CreateObject("Scripting.Dictionary")
rng.Interior.ColorIndex = -4142
I = 3

For Each cell In rng
If cell.Value <> "" Then ' Check if cell is not empty
If objDictDupes.Exists(cell.Value) Then
If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
Else
objDictDupes.Item(cell.Value).Interior.ColorIndex = I
cell.Interior.ColorIndex = I
I = I + 1
End If
Else
objDictDupes.Add cell.Value, cell
End If
End If
Next cell
End Sub
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!
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