मुख्य सामग्री पर जाएं

Excel में विभिन्न रंगों में डुप्लिकेट मानों को कैसे हाइलाइट करें?

लेखक: ज़ियाओयांग अंतिम संशोधित: 2020-12-25
दस्तावेज़ अलग-अलग रंग डुप्लिकेट 1

एक्सेल में, हम इसका उपयोग करके एक कॉलम में डुप्लिकेट मानों को एक रंग के साथ आसानी से हाइलाइट कर सकते हैं सशर्त फॉर्मेटिंग, लेकिन, कभी-कभी, हमें डुप्लिकेट मानों को जल्दी और आसानी से पहचानने के लिए अलग-अलग रंगों में डुप्लिकेट मानों को हाइलाइट करने की आवश्यकता होती है, जैसा कि निम्नलिखित स्क्रीनशॉट में दिखाया गया है। आप एक्सेल में इस कार्य को कैसे हल कर सकते हैं?

वीबीए कोड का उपयोग करके विभिन्न रंगों वाले कॉलम में डुप्लिकेट मानों को हाइलाइट करें

तीर नीला दायां बुलबुला वीबीए कोड का उपयोग करके विभिन्न रंगों वाले कॉलम में डुप्लिकेट मानों को हाइलाइट करें

वास्तव में, एक्सेल में इस काम को पूरा करने का हमारे पास कोई सीधा तरीका नहीं है, लेकिन, नीचे दिया गया वीबीए कोड आपकी मदद कर सकता है, कृपया निम्नानुसार कार्य करें:

1. उन मानों के कॉलम का चयन करें जिन्हें आप भिन्न रंगों के साथ डुप्लिकेट को हाइलाइट करना चाहते हैं, फिर दबाए रखें ALT + F11 कुंजी को खोलने के लिए अनुप्रयोगों के लिए माइक्रोसॉफ्ट विज़ुअल बेसिक खिड़की.

2. क्लिक करें सम्मिलित करें > मॉड्यूल, और निम्नलिखित कोड को इसमें पेस्ट करें मॉड्यूल खिड़की।

वीबीए कोड: डुप्लिकेट मानों को विभिन्न रंगों में हाइलाइट करें:

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. और फिर दबाएं F5 इस कोड को चलाने के लिए कुंजी, और एक प्रॉम्प्ट बॉक्स आपको उस डेटा श्रेणी का चयन करने के लिए याद दिलाएगा जिसे आप डुप्लिकेट मानों को हाइलाइट करना चाहते हैं, स्क्रीनशॉट देखें:

दस्तावेज़ अलग-अलग रंग डुप्लिकेट 2

4। तब दबायें OK बटन, सभी डुप्लिकेट मानों को अलग-अलग रंगों में हाइलाइट किया गया है, स्क्रीनशॉट देखें:

दस्तावेज़ अलग-अलग रंग डुप्लिकेट 1

सर्वोत्तम कार्यालय उत्पादकता उपकरण

🤖 कुटूल्स एआई सहयोगी: निम्न के आधार पर डेटा विश्लेषण में क्रांति लाएं: बुद्धिमान निष्पादन   |  कोड जनरेट करें  |  कस्टम फ़ॉर्मूले बनाएं  |  डेटा का विश्लेषण करें और चार्ट बनाएं  |  कुटूल फ़ंक्शंस का आह्वान करें...
लोकप्रिय सुविधाएँ: डुप्लिकेट ढूंढें, हाइलाइट करें या पहचानें   |  रिक्त पंक्तियाँ हटाएँ   |  डेटा खोए बिना कॉलम या सेल को संयोजित करें   |   फॉर्मूला के बिना गोल ...
सुपर लुकअप: एकाधिक मानदंड VLookup  |   मल्टीपल वैल्यू वीलुकअप  |   अनेक शीटों में VLookup   |   फजी लुकअप ....
उन्नत ड्रॉप-डाउन सूची: शीघ्रता से ड्रॉप डाउन सूची बनाएं   |  आश्रित ड्रॉप डाउन सूची   |  बहु-चयन ड्रॉप डाउन सूची ....
स्तम्भ प्रबंधक: कॉलमों की एक विशिष्ट संख्या जोड़ें  |  कॉलम ले जाएँ  |  छिपे हुए कॉलम की दृश्यता स्थिति टॉगल करें  |  रेंज और कॉलम की तुलना करें ...
फीचर्ड फीचर्स: ग्रिड फोकस   |  डिजाइन देखें   |   बड़ा फॉर्मूला बार   |  कार्यपुस्तिका एवं शीट प्रबंधक   |  संसाधन लाइब्रेरी (ऑटो टेक्स्ट)   |  खजूर बीनने वाला   |  कार्यपत्रकों को संयोजित करें   |  एन्क्रिप्ट/डिक्रिप्ट सेल   |  सूची के अनुसार ईमेल भेजें   |  सुपर फ़िल्टर   |   विशेष फ़िल्टर (फ़िल्टर बोल्ड/इटैलिक/स्ट्राइकथ्रू...) ...
शीर्ष 15 टूलसेट:  12 टेक्स्ट टूल्स (पाठ जोड़ें, अक्षर हटाएँ, ...)   |   50 + चार्ट प्रकार (गैन्ट चार्ट, ...)   |   40+ प्रैक्टिकल सूत्र (जन्मदिन के आधार पर आयु की गणना करें, ...)   |   19 निवेशन टूल्स (QR कोड डालें, पथ से चित्र सम्मिलित करें, ...)   |   12 रूपांतरण टूल्स (शब्दों को संख्याएँ, मुद्रा रूपांतरण, ...)   |   7 विलय और विभाजन टूल्स (उन्नत संयोजन पंक्तियाँ, विभाजन कोशिकाओं, ...)   |   ... और अधिक

एक्सेल के लिए कुटूल के साथ अपने एक्सेल कौशल को सुपरचार्ज करें, और पहले जैसी दक्षता का अनुभव करें। एक्सेल के लिए कुटूल उत्पादकता बढ़ाने और समय बचाने के लिए 300 से अधिक उन्नत सुविधाएँ प्रदान करता है।  वह सुविधा प्राप्त करने के लिए यहां क्लिक करें जिसकी आपको सबसे अधिक आवश्यकता है...

Description

ऑफिस टैब ऑफिस में टैब्ड इंटरफ़ेस लाता है, और आपके काम को बहुत आसान बनाता है

  • Word, Excel, PowerPoint में टैब्ड संपादन और रीडिंग सक्षम करें, प्रकाशक, एक्सेस, विसियो और प्रोजेक्ट।
  • नई विंडो के बजाय एक ही विंडो के नए टैब में एकाधिक दस्तावेज़ खोलें और बनाएं।
  • आपकी उत्पादकता 50% बढ़ जाती है, और आपके लिए हर दिन सैकड़ों माउस क्लिक कम हो जाते हैं!
Comments (98)
Rated 5 out of 5 · 1 ratings
strulip.rva@gmail.com
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
Reply
Report
0
0
Volker Maier
Volker Maier
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
Reply
0
0
strulip.rva@gmail.com
    Volker Maier
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
Reply
Report
0
0
Manfred James Dandan
Manfred James Dandan
This comment was minimized by the moderator on the site
Very helpful! Thanks a lot for sharing :-)
Reply
0
0
mahmoud
mahmoud
This comment was minimized by the moderator on the site
it only applies to 5 duplicates then don't work
Reply
0
0
EsA
EsA
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot...
Reply
Report
0
0
Rated 5 out of 5
EsA
EsA
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot..
Reply
0
0
Rated 5 out of 5
Christina L
Christina L
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?
Reply
0
0
ALEJANDRO
ALEJANDRO
This comment was minimized by the moderator on the site
Funcionó perfecto. Muchas gracias.
Reply
0
0
pucci
pucci
This comment was minimized by the moderator on the site
perfect, i love u
Reply
0
0
hayyi
hayyi
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 
Reply
0
0
skyyang
skyyang     hayyi
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！
Reply
Report
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations