Note: The other languages of the website are Google-translated. Back to English
Увійти  \/ 
x
or
x
Реєстрація  \/ 
x

or

Як виділити повторювані значення різними кольорами в Excel?

doc різні кольори дублює 1

В Excel ми можемо легко виділити повторювані значення в стовпці одним кольором за допомогою Умовне форматування, але, іноді нам потрібно виділити повторювані значення різними кольорами, щоб швидко і легко розпізнати дублікати, як показано на наступному скріншоті. Як ви могли вирішити це завдання в Excel?

Виділіть повторювані значення в стовпці різними кольорами за допомогою коду VBA


стрілка синя права міхур Виділіть повторювані значення в стовпці різними кольорами за допомогою коду VBA

Насправді у нас немає прямого способу закінчити цю роботу в Excel, але, наведений нижче код VBA може вам допомогти, зробіть наступне:

1. Виділіть стовпець значень, які потрібно виділити дублікатами різницевими кольорами, а потім утримуйте клавішу ALT + F11 ключі, щоб відкрити Microsoft Visual Basic для додатків вікна.

2. Натисніть Insert > Модуліта вставте наступний код у Модулі Вікно

Код VBA: Виділіть повторювані значення різними кольорами:

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 клавішу для запуску цього коду, і підказка нагадає вам вибрати діапазон даних, для якого потрібно виділити повторювані значення, див. знімок екрана:

doc різні кольори дублює 2

4. Потім натисніть OK кнопку, всі повторювані значення були виділені різними кольорами, див. знімок екрана:

doc різні кольори дублює 1


Найкращі інструменти для підвищення продуктивності офісу

Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%

  • Повторне використання: Швидко вставте складні формули, діаграми і все, що ви використовували раніше; Шифрувати комірки з паролем; Створити список розсилки та надсилати електронні листи ...
  • Супер формула бар (легко редагувати кілька рядків тексту та формули); Макет читання (легко читати та редагувати велику кількість комірок); Вставте у відфільтрований діапазон...
  • Об’єднати клітинки / рядки / стовпці без втрати даних; Вміст розділених комірок; Об'єднати повторювані рядки / стовпці... Запобігання дублюючим клітинам; Порівняйте діапазони...
  • Виберіть Повторюваний або Унікальний Рядки; Виберіть Пусті рядки (усі клітинки порожні); Супер знахідка та нечітка знахідка у багатьох робочих зошитах; Випадковий вибір ...
  • Точна копія Кілька клітинок без зміни посилання на формулу; Автоматичне створення посилань на кілька аркушів; Вставте кулі, Прапорці та інше ...
  • Витяг тексту, Додати текст, Видалити за позицією, Видаліть пробіл; Створення та друк проміжних підсумків підкачки; Перетворення вмісту комірок та коментарів...
  • Супер фільтр (зберегти та застосувати схеми фільтрів до інших аркушів); Розширене сортування за місяцем / тижнем / днем, частотою та іншим; Спеціальний фільтр жирним, курсивом ...
  • Поєднайте робочі зошити та робочі аркуші; Об’єднати таблиці на основі ключових стовпців; Розділіть дані на кілька аркушів; Пакетне перетворення xls, xlsx та PDF...
  • Понад 300 потужних функцій. Підтримує Office / Excel 2007-2019 та 365. Підтримує всі мови. Простота розгортання на вашому підприємстві чи в організації. Повна функція 30-денної безкоштовної пробної версії. 60-денна гарантія повернення грошей.
вкладка kte 201905

Вкладка Office забезпечує інтерфейс з вкладками для Office і значно спрощує вашу роботу

  • Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
  • Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
  • Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!
дно офісної таблиці
Say something here...
symbols left.
You are guest
or post as a guest, but your post won't be published automatically.
Loading comment... The comment will be refreshed after 00:00.
  • To post as a guest, your comment is unpublished.
    Zmusiclover · 12 days ago
    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?
  • To post as a guest, your comment is unpublished.
    Sadie737 · 9 months ago
    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!
    • To post as a guest, your comment is unpublished.
      skyyang · 9 months ago
      Hi, Sadie,
      To ignore the empty cells, please apply the below 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 Sub
      Please try, hope it can help you!
      • To post as a guest, your comment is unpublished.
        Julie · 3 months ago
        Hello,

        I there a way to highlight opposite instead of duplicate and ignore empty cells?

        Thanks
  • To post as a guest, your comment is unpublished.
    sajith · 11 months ago
    IS THERE ANY VBA CODE TO HIGHLIGHT DUPLICATES BY DIFFERENT FONT COLORS?


    • To post as a guest, your comment is unpublished.
      skyyang · 11 months ago
      Hello, sajith,
      To highlight the duplicates with different font colors, please apply the below formula:
      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.Font.ThemeColor = xlNone Then xCellPre.Font.ThemeColor = xCIndex xCell.Font.ThemeColor = xCellPre.Font.ThemeColor 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
      Please try, hope it can help you!
      • To post as a guest, your comment is unpublished.
        Sajith · 11 months ago
        Thanks a lot. Can I have a email or something?
        • To post as a guest, your comment is unpublished.
          sajith · 10 months ago
          It's not working. something wrong?

  • To post as a guest, your comment is unpublished.
    FannieM · 11 months ago
    Hello I need help highlighting cells only if they repeat consecutively with 2 cell colors. This is a sample of end result.

    95
    83
    68
    94
    97
    95.** Highlight with color 1
    95 ** Highlight with color 1
    95** Highlight with color 1
    78
    92
    65
    85
    79
    94
    83
    91
    68** Highlight with 2nd color
    68** Highlight with 2nd color
    68** Highlight with 2nd color
    80
    70
    83**Highlight with color 1
    83**Highlight with color 1
    94
    65
    83
    12
    65** Highlight with 2nd color
    65** Highlight with 2nd color
    65** Highlight with 2nd color


  • To post as a guest, your comment is unpublished.
    FannieM · 11 months ago
    Hello, I need help highlighting duplicate values only if they are found repeating consecutively as a group using only two colors. if they appear only once elsewhere do not highlight.

    can someone help me with a code please?
    This is the sample end result i'm looking for.
  • To post as a guest, your comment is unpublished.
    ganesh ugale · 1 years ago
    You are champion..!!!

  • To post as a guest, your comment is unpublished.
    MB · 1 years ago
    How to Highlight Duplicate rows In A table With Different Colors By Using VBA Code ?
  • To post as a guest, your comment is unpublished.
    MB · 1 years ago
    Highlight Duplicate rows In A table With Different Colors By Using VBA Code

  • To post as a guest, your comment is unpublished.
    Pavithra · 1 years ago
    this macro stops after every 100 rows. I ahve dtaa with more than 5000 rows. then What Should i do with the code.
    • To post as a guest, your comment is unpublished.
      skyyang · 1 years ago
      Hello, Pavithra,
      This code works well in my worksheet, which Excel version do you use?
      Or you can send your worksheet to my email, I test it for you!
      Thank you!
  • To post as a guest, your comment is unpublished.
    luis · 1 years ago
    hola y si quisiera combinar todas las celdas repetidas con sus similares
    de forma automática?? hacerlas una sola
  • To post as a guest, your comment is unpublished.
    Kelli · 1 years ago
    Whenever I run this code it seems to work for a few seconds (I can see the various colors in the appropriate column...) but when I try to scroll down to see the entire sheet, everything freezes. Eventually I get an error message that Excel is not responding... Any suggestions? My guess is that my spreadsheet is too large? Or I have too many Duplicate Vales and it's throwing Excel for a loop?? i.e. Recent spreadsheet had 567 cells in the column I was attempting to format and there were around 267 duplicates... Too much? Not enough colors in the rainbow, possibly? ;)
  • To post as a guest, your comment is unpublished.
    Douglas · 2 years ago
    what is the limit of duplicate values for the code to work properly?
  • To post as a guest, your comment is unpublished.
    debbie · 2 years ago
    I'm a beginner (obviously), but I keep getting the following error "Compile Error: Invalid outside procedure." Any suggestions?
    • To post as a guest, your comment is unpublished.
      skyyang · 2 years ago
      Hello, debbie,
      The code works well in my worksheet, which Excel version do you use?
      Or you can insert your problem screenshot here.
  • To post as a guest, your comment is unpublished.
    Peter · 2 years ago
    Hallo and thx for your work - know its long time ago but still great to use

    I use it in a large address list and filter out all double entry’s - help a lot

    Now my question - is it possible to run this macro in some kind of live error check - I mean - if someone enter a doable address it get colored directly when I press enter.


    Sub ColorCompanyDuplicates()
    'Updateby Extendoffice 20171222
    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 = Range("M10:P10010")
    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.Color = RGB(xRed, xGreen, xBlue)
    xCell.Interior.Color = xCellPre.Interior.Color
    ElseIf Err.Number = 9 Then
    MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
    Exit Sub
    End If
    xRed = Application.WorksheetFunction.RandBetween(0, 255)
    xGreen = Application.WorksheetFunction.RandBetween(0, 255)
    xBlue = Application.WorksheetFunction.RandBetween(0, 255)
    On Error GoTo 0
    End If
    Next
    End Sub


    Thx for your help
    • To post as a guest, your comment is unpublished.
      skyyang · 2 years ago
      Hi, Peter,
      Sorry, maybe there is no direct code for coloring the cells dynamically when entering new data.
      If others have any good ideas, please comment here.
      Thank you!
  • To post as a guest, your comment is unpublished.
    alex · 2 years ago
    I have 1039 rows some have duplicate names but when I run the code it seems to only highlight 100 of the rows and in between it misses some. Is the problem not to many colors? or is it too much to process? (there might be like 500-800 names that repeat)
  • To post as a guest, your comment is unpublished.
    Thomas · 2 years ago
    Because you are limited to 56 Colours using the *.ColorIndex you should probably consider using RGB colours.

    I have modified the code (note there is no if-statement for duplicate coloruing)…

    Sub ColorCompanyDuplicates()
    'Updateby Extendoffice 20160704
    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.Color = RGB(xRed, xGreen, xBlue)
    xCell.Interior.Color = xCellPre.Interior.Color
    ElseIf Err.Number = 9 Then
    MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
    Exit Sub
    End If
    xRed = Application.WorksheetFunction.RandBetween(0, 255)
    xGreen = Application.WorksheetFunction.RandBetween(0, 255)
    xBlue = Application.WorksheetFunction.RandBetween(0, 255)
    On Error GoTo 0
    Next
    End Sub
    • To post as a guest, your comment is unpublished.
      nasa · 1 years ago
      Thank you so much Thomas! You just saved me!
    • To post as a guest, your comment is unpublished.
      javier · 2 years ago
      Woow man, thanks !!! exactly what I was looking for!
    • To post as a guest, your comment is unpublished.
      skyyang · 2 years ago
      Dear, Thomas,
      Thanks a lot for your code, your are a warm-hearted man, the code may help for others!
      Thanks again!
  • To post as a guest, your comment is unpublished.
    AW · 2 years ago
    How can you make it color the entire document if there are many rows?
    • To post as a guest, your comment is unpublished.
      skyyang · 2 years ago
      Hi, AW,
      To highlight entire documnet based on the duplicate cell values, you can apply the following VBA code:

      Sub ColorCompanyDuplicates()
      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

      Please try it, hope it can help you!
  • To post as a guest, your comment is unpublished.
    Miles · 2 years ago
    Thanks for posting this, it's been very helpful! Which lines in the VBA code designate which colors will be used? I was looking for hex color codes in there but nothing was popping out.
    • To post as a guest, your comment is unpublished.
      skyyang · 2 years ago
      Hi, Miles,
      The above VBA code can not support to choose the colors, it fills the cells with random background color.
      If you have other good ideas, please comment here.
      Thank you!
  • To post as a guest, your comment is unpublished.
    Bree · 2 years ago
    Nvm i got it to work.
  • To post as a guest, your comment is unpublished.
    Bree · 2 years ago
    I can't get it to work it keeps crashing my Excel.
  • To post as a guest, your comment is unpublished.
    Татьяна · 2 years ago
    Огромное СПАСИБО !!!!
  • To post as a guest, your comment is unpublished.
    Prashanth · 3 years ago
    Oh Damn, You saved my time,,I was taking help of my colleagues all these days and no one had idea about it. Thanks a Ton !!!
  • To post as a guest, your comment is unpublished.
    Carol · 3 years ago
    My spreadsheet also stopped coloring at 178 and I have over 400 lines. How do you fix this?
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hello, Carol,
      Could you send your workbook to my email address, I may help you to find the problem.
      My email address is :skyyang@extendoffice.com
  • To post as a guest, your comment is unpublished.
    hidayat_wijaya · 3 years ago
    This is really great, but colouring stopped after row 76 (5 colours). How can I this be extended too?
  • To post as a guest, your comment is unpublished.
    Anri · 3 years ago
    This is really great, but colouring stopped after row 66 (9 colours). How can I this be extended?
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hello, Anri,
      The above code works well in my worksheet, i test it in 300 hundred rows.
      Please try it again. Or you can send your workbook file to my email account.
      My email account is: skyyang@extendoffice.com
      • To post as a guest, your comment is unpublished.
        Ahmed · 3 years ago
        Hello,
        my excel sheet has 11000 row of data.
        how can I extend it to highlight all the duplicate in that long column.

        it stopped at row 77.

        Thanks,

        AK
      • To post as a guest, your comment is unpublished.
        bruceluo7701@gmail.com · 3 years ago
        there is some mistake regarding the colorindex setting, xCindex will be more than 56 if there are 56 row data in your sheet, system will ignore the sentence :
        If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
        xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
        I correct the program like below: \
        if Err.number=457 then
        if xCellPre.Text<>xCell.Text Then
        xCindex=xCindex+1
        endif
        set.....
  • To post as a guest, your comment is unpublished.
    Priya · 3 years ago
    I am new to VBA. Is there any way, that we need not run the macro over and over, it is automated to highlight even if new cells are copied into the column where macro is programmed?
  • To post as a guest, your comment is unpublished.
    Vasil · 3 years ago
    Is there a way to change the script to work for (look at) table array instead of column? For example F2:BC117.
    Thank you!
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hello, Vasil,
      To highlight duplicate values in a range of cell, please try the following vba code:

      Sub ColorCompanyDuplicates()
      'Updateby Extendoffice
      Dim xRg, xRgRow As Range
      Dim xTxt, xStr As String
      Dim xCell, xCellPre As Range
      Dim xCIndex As Long
      Dim xCol As Collection
      Dim I As Long
      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 I = 1 To xRg.Rows.Count
      On Error Resume Next
      Set xRgRow = xRg.Rows(I)
      For Each xCell In xRgRow.Columns
      xStr = xStr & xCell.Text
      Next
      xCol.Add xRgRow, xStr
      If Err.Number = 457 Then
      xCIndex = xCIndex + 1
      Set xCellPre = xCol(xStr)
      If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
      xRgRow.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
      xStr = ""
      Next
      End Sub

      Hope it can help you.
  • To post as a guest, your comment is unpublished.
    Bobo · 3 years ago
    Is there a way to highlight the entire row instead of 1 column?
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hi, Bobo,
      To highlight entire row based on the duplicate cell values, you can apply the following VBA code:

      Sub ColorCompanyDuplicates()
      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

      Please try it, hope it can help you!
      • To post as a guest, your comment is unpublished.
        Hossein · 3 years ago
        how can I highlight the range of rows?
        • To post as a guest, your comment is unpublished.
          skyyang · 3 years ago
          Hello, Hossein,
          May be the following code can do you a favor, please try it.

          Sub ColorCompanyDuplicates()
          'Updateby Extendoffice
          Dim xRg, xRgRow As Range
          Dim xTxt, xStr As String
          Dim xCell, xCellPre As Range
          Dim xCIndex As Long
          Dim xCol As Collection
          Dim I As Long
          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 I = 1 To xRg.Rows.Count
          On Error Resume Next
          Set xRgRow = xRg.Rows(I)
          For Each xCell In xRgRow.Columns
          xStr = xStr & xCell.Text
          Next
          xCol.Add xRgRow, xStr
          If Err.Number = 457 Then
          xCIndex = xCIndex + 1
          Set xCellPre = xCol(xStr)
          If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
          xRgRow.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
          xStr = ""
          Next
          End Sub
  • To post as a guest, your comment is unpublished.
    selim · 3 years ago
    What If I just want to fill with only two colors, let's say yellow and red, repeatedly. To be clear, on the example in this page, 'Rachel' is yellow, Rose is red and again Sussies are yellow, Tedi is red.
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hello, selim,
      The following code may solve your problem, please try.

      Sub ColorCompanyDuplicates()
      'Updateby Extendoffice 20170504
      Dim xRg As Range
      Dim xTxt As String
      Dim xCell As Range
      Dim xChar As String
      Dim xCellPre As Range
      Dim xRgTemp 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 = 3
      Set xCol = New Collection
      For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
      Set xCellPre = xCol(xCell.Text)
      xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
      MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
      Exit Sub
      Else
      xCell.Interior.ColorIndex = xCIndex
      Set xRgTemp = xCell
      xCIndex = IIf(xRgTemp.Interior.ColorIndex = 3, 4, 3)
      End If
      On Error GoTo 0
      Next
      End Sub

      Hope it can help you!
      • To post as a guest, your comment is unpublished.
        selim · 3 years ago
        This is what I exactly want it. Thank you much, skyyang.
  • To post as a guest, your comment is unpublished.
    Asking Man · 3 years ago
    Hello, I have Excel 2016, alt+F11 does work anymore to bring up Microsoft VB? is Microsoft visual basic free software? Thank you.
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hi,
      If you can not activate the Microsoft VB window by holding down Alt + F11 keys, you can click Developer > Visual Basic to open it.

      Please try it, thank you!
  • To post as a guest, your comment is unpublished.
    shahinshah · 3 years ago
    Sir,
    How to differentiate different colors given in the data on the basis of frequency?
    In very large data same color has been given repeatedly without considering their frequency.
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Sorry, can you give more detailed information,you can attach a screenshot here.
      Thank you!
  • To post as a guest, your comment is unpublished.
    gopi · 3 years ago
    without empty to change a colour how ????????????????????
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hello, gopi,
      To avoid the blank cells, please apply the following VBA code:
      Sub ColorCompanyDuplicates()
      'Updateby Extendoffice 20171222
      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 Sub

      Hope it can help you, thank you!
  • To post as a guest, your comment is unpublished.
    bhaggi · 3 years ago
    how to change colour ?
    • To post as a guest, your comment is unpublished.
      eddvp · 3 years ago
      the same problem with me... color is too dark to read...
    • To post as a guest, your comment is unpublished.
      skyyang · 3 years ago
      Hi,
      The code only can help you add the different color randomly, it can't change the color.
      Thank you!
      • To post as a guest, your comment is unpublished.
        John · 3 years ago
        It seems to always use the same color palette though, is there a way to select the palette it uses? It's giving me some really dark colors through which the text is unreadable.
  • To post as a guest, your comment is unpublished.
    SHRIKANT NAYAK · 4 years ago
    I am really happy as I got what I was needed. Thanks
  • To post as a guest, your comment is unpublished.
    Sarah · 4 years ago
    This is great and EXACTLY what I was looking for! I'm incorporating this code into some existing code - I've written my code to select the cells that I want to color, and then I call the code to do the coloring. The only thing I can't figure out is how to bypass the msgBox that pops up and I have to click OK. I'm a novice at VBA and can't quite figure out how to alter this code.... Any suggestions, please! :)
    • To post as a guest, your comment is unpublished.
      Wojciech Radwan · 3 years ago
      Replace line: Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
      to
      Set xRg = Range("A1:A100")

      or if you have table you can apply to whole table column:
      Set xRg = Range("Table1[[#All],[Column1]]")

      just replace Table1 to your own name and Column1 to any table header you wish to apply this macro.


      Regards
      Wojciech
  • To post as a guest, your comment is unpublished.
    Jason · 4 years ago
    I tried running this several times and every time I click "ok" it just sends me back to the modules screen. I'm using Excel 2010.
  • To post as a guest, your comment is unpublished.
    Josh · 4 years ago
    I had the same problem, the problem is the color index only goes to 56, so once it passes that it no longer colors the cells. To fix that, I replaced the line "xCIndex = xCIndex + 1" with the following:

    If xCIndex > 55 Then
    xCIndex = 3
    Else
    xCIndex = xCIndex + 1
    End If

    It will start reusing colors eventually, but that wasn't an issue for me.
    • To post as a guest, your comment is unpublished.
      Golzar · 3 years ago
      Thank you so much Josh, it works!
    • To post as a guest, your comment is unpublished.
      FRANK · 4 years ago
      The replace with

      If xCIndex > 55 Then
      xCIndex = 3
      Else
      xCIndex = xCIndex + 1
      End If



      Did not work. Trying to get this to work on 14000 lines, approx 6000 duplicates
      • To post as a guest, your comment is unpublished.
        Golzar · 3 years ago
        It worked for me, I indented the second and fourth lines. See below. Josh's code is bolded.

        If Err.Number = 457 Then
        If xCIndex > 55 Then
        xCIndex = 3
        Else
        xCIndex = xCIndex + 1
        End If
        Set xCellPre = xCol(xCell.Text)
  • To post as a guest, your comment is unpublished.
    ES · 4 years ago
    Same problem. Anyone figure this out?
  • To post as a guest, your comment is unpublished.
    Golzar · 4 years ago
    This has been a life saver for me, thank you so much for sharing!

    When I run it on about 2000 cells with values, it only highlights some of the duplicates. Is there a way to fix that? I wonder if it runs out of colors or there is something else.
    • To post as a guest, your comment is unpublished.
      yp · 4 years ago
      same problem i am trying with couple of hundred cells and very quickly it colors in same colors.
      is there a fix for this?
      thanks
  • To post as a guest, your comment is unpublished.
    Swapnil · 4 years ago
    i want to check the duplicates for 5000 cells which i am not able to do. i can highlight duplicates upto 70 to 80 cells
    • To post as a guest, your comment is unpublished.
      JOTA475 · 1 months ago
      Sub BuscarD()
      Dim xRg As Range
      Dim xTxt As String
      Dim xCell As Range
      Dim xChar As String
      Dim xCellPre As Range
      Dim xCol As Collection
      Dim I As Long
      Dim J As Integer
      Dim K As Integer
      Dim xCLR As Integer

      xCLR = 28

      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("Seleccione el rango a evaluar:", "Buscar duplicados", xTxt, , , , , 8)
      If xRg Is Nothing Then Exit Sub
      J = 0
      K = 0
      Set xCol = New Collection
      For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
      Set xCellPre = xCol(xCell.Text)
      If xCellPre.Interior.ColorIndex = xlNone Then
      xCellPre.Interior.Color = RGB(255, J, K)
      xCell.Interior.Color = RGB(255, J, K)
      If K + xCLR <= 255 Then
      K = K + xCLR
      Else
      If J + xCLR <= 255 Then
      K = 0
      J = J + xCLR
      Else
      MsgBox "!Demasiados datos duplicados!: Reducir variable xCLR", vbCritical, "Error"
      Exit Sub
      End If
      End If
      Else
      xCell.Interior.Color = xCellPre.Interior.Color
      End If
      ElseIf Err.Number = 9 Then
      MsgBox "Demasiados datos duplicados!", vbCritical, "Error"
      Exit Sub
      End If
      On Error GoTo 0
      Next

      End Sub


      Es un tema viejo, pero lo dejo por si alguien lo necesita. Con el código anterior y modificando la variable "xCLR", desde 1 a 255, se pueden obtener desde 4 hasta 65.000 colores diferentes. En mi caso, configuré el rojo del RGB con un valor estático de 255 y varío los valores verde y azul (255, X, X). Si se requieren mas colores, se podría alterar el valor del rojo, logrando mas de 166 millones de colores diferentes
  • To post as a guest, your comment is unpublished.
    Patrick A. · 4 years ago
    This is just what I needed, thank you.

    Sometimes when I run this code Excel just freezes, I am using Office 2016 / Windows 10 any idea why?
    • To post as a guest, your comment is unpublished.
      Alan · 4 years ago
      Patrick, only highlight the cells you want. Don't highlight the entire column which will include all the thousands of blank cells
  • To post as a guest, your comment is unpublished.
    Edward · 4 years ago
    It worked for me on a list of part numbers.
    • To post as a guest, your comment is unpublished.
      Alex · 2 years ago
      Hello,

      Is there a way to make this only effect the highlighted column and not the entire row? Some of the bold red and blue colors are hard to look at all the way across the spreadsheet. Thanks