VBA option to highlight duplicates in more than one column

S

Serafin54

Board Regular
Joined
Apr 11, 2014
Messages
155
Office Version
  1. 2016
Platform
  1. Windows
Hello,

Is there a way to select a range and highlight if there are duplicates in two or more of the selected range? For instance, in the sheet below, though the same 4 people are listed, column A isn't highlighted until there's a secondary match in B then again in C and D. I know a helper column can be used but looking to see if there's a macro that can be run to speed up the task as it is daily and sometimes 2 to 3 times per.

The caveat is that this would need to be selection range based

NameDateAmountDeduction
John Smith01/01/202110010
Michael Johnson01/02/202150015
Laura White01/02/202190020
Michelle Thomas01/04/2021130025
Michael Johnson01/01/2021170030
Laura White01/06/2021210035
Michelle Thomas01/01/2021250040
John Smith01/04/2021290045
John Smith01/01/202110010
Laura White01/04/2021370055
Michelle Thomas01/01/2021410060
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Hello, try this VBA demonstration :​
VBA Code: 
Sub Demo1()
        Dim V, W, F&, C%, N%, R&
    With Selection.Columns
            V = Evaluate(.Item(1).Address & "&" & .Item(2).Address):  If Not IsArray(V) Then Beep: Exit Sub
            W = .Item("C:D").Value2
            Application.ScreenUpdating = False
        For F = 1 To UBound(V) - 1
            C = 0
        For R = F + 1 To UBound(V)
            If V(R, 1) = V(F, 1) Then
                N = 1 - (W(R, 1) = W(F, 1)) * 2 - (W(R, 2) = W(F, 2)) * 4
                C = Application.Max(C, N)
               .Cells(R, 1).Resize(, 2).Interior.Color = vbYellow
                If N And 2 Then .Cells(R, 3).Interior.Color = vbYellow
                If N And 4 Then .Cells(R, 4).Interior.Color = vbYellow
            End If
        Next
            If C Then
               .Cells(F, 1).Resize(, 2).Interior.Color = vbYellow
                If C And 2 Then .Cells(F, 3).Interior.Color = vbYellow
                If C And 4 Then .Cells(F, 4).Interior.Color = vbYellow
            End If
        Next
    End With
            Application.ScreenUpdating = True
End Sub
 
Upvote 0
My code revamped to avoid some glitch :​
VBA Code: 
Sub Demo1r()
        Dim V, W, F&, C%, R&
    With Selection.Columns
            V = Evaluate(.Item(1).Address & "&" & .Item(2).Address):  If Not IsArray(V) Then Beep: Exit Sub
            W = .Item("C:D").Value2
            Application.ScreenUpdating = False
        For F = 1 To UBound(V) - 1
            C = 0
        For R = F + 1 To UBound(V)
            If V(R, 1) = V(F, 1) Then
                              .Cells(R, 1).Resize(, 2).Interior.Color = vbYellow: If C = 0 Then C = 1
                If W(R, 1) = W(F, 1) Then .Cells(R, 3).Interior.Color = vbYellow: If (C And 2) = 0 Then C = C + 2
                If W(R, 2) = W(F, 2) Then .Cells(R, 4).Interior.Color = vbYellow: If (C And 4) = 0 Then C = C + 4
            End If
        Next
            If C Then
                    .Cells(F, 1).Resize(, 2).Interior.Color = vbYellow
                If C And 2 Then .Cells(F, 3).Interior.Color = vbYellow
                If C And 4 Then .Cells(F, 4).Interior.Color = vbYellow
            End If
        Next
    End With
            Application.ScreenUpdating = True
End Sub
 
Upvote 0
Marc L said:
My code revamped to avoid some glitch :​
VBA Code: 
Sub Demo1r()
        Dim V, W, F&, C%, R&
    With Selection.Columns
            V = Evaluate(.Item(1).Address & "&" & .Item(2).Address):  If Not IsArray(V) Then Beep: Exit Sub
            W = .Item("C:D").Value2
            Application.ScreenUpdating = False
        For F = 1 To UBound(V) - 1
            C = 0
        For R = F + 1 To UBound(V)
            If V(R, 1) = V(F, 1) Then
                              .Cells(R, 1).Resize(, 2).Interior.Color = vbYellow: If C = 0 Then C = 1
                If W(R, 1) = W(F, 1) Then .Cells(R, 3).Interior.Color = vbYellow: If (C And 2) = 0 Then C = C + 2
                If W(R, 2) = W(F, 2) Then .Cells(R, 4).Interior.Color = vbYellow: If (C And 4) = 0 Then C = C + 4
            End If
        Next
            If C Then
                    .Cells(F, 1).Resize(, 2).Interior.Color = vbYellow
                If C And 2 Then .Cells(F, 3).Interior.Color = vbYellow
                If C And 4 Then .Cells(F, 4).Interior.Color = vbYellow
            End If
        Next
    End With
            Application.ScreenUpdating = True
End Sub
Click to expand...
This one is just about flawless except if i select the columns themselves, the code seems to hang and i have to restart excel. I can skirt around the issue by selecting the range itself but is there a way to tell it to stop at the end of the range?

And since our controller just asked as she saw me run this, is there a way to tweak it for only highlighting if the entire row in the selected range is a match? Meaning, the selected range could be as few as 2 columns and up. In the example below, i highlighted the columns in blue and if the code finds matches among all, would highlight those rows so 4,5 and 26,27 should be the only ones highlighted.

To me this sounds like an enormous task so please let me know if that's so.

DeptWorker IDWorker NameWorkedTime PeriodCheck DateTAX | Income Tax WithheldTAX | Social SecurityTAX | MedicareNet PayDED | 95 Net CheckingERN | 16 BonusERN | 06 Personal
9989270Callanan, LisaFederalCheck Date - Qtr 307.16.2021136.57107.5625.161419.72
9989270Callanan, LisaCACheck Date - Qtr 307.16.202145.84
998915Henry III, JamesFederalCheck Date - Qtr 307.16.2021295.87176.9541.382096.23
998915Henry III, JamesCACheck Date - Qtr 307.16.202183.34
998936Johnson, WilliamaFederalCheck Date - Qtr 307.16.2021442.65162.3737.97
998936Johnson, WilliamaCACheck Date - Qtr 307.16.2021175.46
9989181Mason, Nell BFederalCheck Date - Qtr 307.16.2021223.96139.8032.691584.21
9989181Mason, Nell BCACheck Date - Qtr 307.16.202163.26
99896Reyes, David KFederalCheck Date - Qtr 307.16.2021223.39118.4627.701471.45
99896Reyes, David KCACheck Date - Qtr 307.16.202166.85
9989346Austin, Andrew BFederalCheck Date - Qtr 307.16.202188.1679.4318.581056.16
9989346Austin, Andrew BCACheck Date - Qtr 307.16.202138.83
9989354Becker, BrettFederalCheck Date - Qtr 307.16.2021104.8924.531269.82
9989354Becker, BrettCACheck Date - Qtr 307.16.202152.59
9989270Callanan, LisaFederalCheck Date - Qtr 307.16.2021159.25126.4229.561676.52
9989270Callanan, LisaCACheck Date - Qtr 307.16.202147.21
9989345Brenenstuhl, Raven RFederalCheck Date - Qtr 307.16.202112.1837.488.77529.92
9989345Brenenstuhl, Raven RCACheck Date - Qtr 307.16.202116.16
9989118Clark, David DFederalCheck Date - Qtr 307.16.202172.6767.9515.89915.00
9989118Clark, David DCACheck Date - Qtr 307.16.202124.44
9989208Crane, Tyler JFederalCheck Date - Qtr 307.16.2021125.5678.2518.301001.77
9989208Crane, Tyler JCACheck Date - Qtr 307.16.202138.19
9989344Crowl, Hunter MFederalCheck Date - Qtr 307.16.202141.399.68598.19
9989344Crowl, Hunter MCACheck Date - Qtr 307.16.202118.27
998915Henry III, JamesFederalCheck Date - Qtr 307.16.2021295.87176.9541.382096.23
998915Henry III, JamesCACheck Date - Qtr 307.16.202183.34
9989343Henderson, ErikaFederalCheck Date - Qtr 307.16.202124.5086.2820.181223.86
9989343Henderson, ErikaCACheck Date - Qtr 307.16.202136.86
9989353Hulbert, IanFederalCheck Date - Qtr 307.16.202167.9068.9616.13907.39
9989353Hulbert, IanCACheck Date - Qtr 307.16.202133.17
9989110Jeandell, NathanlFederalCheck Date - Qtr 307.16.202154.3712.72784.53
9989110Jeandell, NathanlCACheck Date - Qtr 307.16.202125.29
 
Upvote 0
Hello Serfin54,
you can try this version.
Select some range and run this code.
I didn't test the speed, may be slow on the big size data.
Hope so it will do what you expect.
VBA Code: 
Sub HighLightDuplicatesThroughColumns()

    Dim vA, vA1

    Set vRng = Selection
    If vRng.Columns.Count < 2 Then
        MsgBox "Select more then one column.": Exit Sub
    End If
    vA = vRng
    vRng.Interior.Color = xlNone
    vR = UBound(vA)
    vC = UBound(Application.Transpose(vA))
    ReDim vA1(1 To vR, 1 To 2)
    For vN1 = 2 To vC
        For vN2 = 1 To vR
            vS = vS & vA(vN2, 1)
            For vN3 = 2 To vN1
                vS = vS & vA(vN2, vN3)
            Next vN3
            vA1(vN2, 1) = vS
            vA1(vN2, 2) = vS
            vS = ""
        Next vN2
        For vN3 = 1 To vR - 1
            For vN4 = vN3 + 1 To vR
                If vA1(vN3, 1) = vA1(vN4, 2) Then
                    vRng.Range(Cells(vN4, 1), Cells(vN4, vN1)). _
                        Interior.Color = vbYellow
                    vColored = True
                End If
            Next vN4
            If vColored = True Then _
                vRng.Range(Cells(vN3, 1), Cells(vN3, vN1)). _
                    Interior.Color = vbYellow
             vColored = False
        Next vN3
    Next vN1
   
End Sub
 
Last edited:
Upvote 0
EXCEL MAX said:
Hello Serfin54,
you can try this version.
Select some range and run this code.
I didn't test the speed, may be slow on the big size data.
Hope so it will do what you expect.
VBA Code: 
Sub HighLightDuplicatesThroughColumns()

    Dim vA, vA1

    Set vRng = Selection
    If vRng.Columns.Count < 2 Then
        MsgBox "Select more then one column.": Exit Sub
    End If
    vA = vRng
    vRng.Interior.Color = xlNone
    vR = UBound(vA)
    vC = UBound(Application.Transpose(vA))
    ReDim vA1(1 To vR, 1 To 2)
    For vN1 = 2 To vC
        For vN2 = 1 To vR
            vS = vS & vA(vN2, 1)
            For vN3 = 2 To vN1
                vS = vS & vA(vN2, vN3)
            Next vN3
            vA1(vN2, 1) = vS
            vA1(vN2, 2) = vS
            vS = ""
        Next vN2
        For vN3 = 1 To vR - 1
            For vN4 = vN3 + 1 To vR
                If vA1(vN3, 1) = vA1(vN4, 2) Then
                    vRng.Range(Cells(vN4, 1), Cells(vN4, vN1)). _
                        Interior.Color = vbYellow
                    vColored = True
                End If
            Next vN4
            If vColored = True Then _
                vRng.Range(Cells(vN3, 1), Cells(vN3, vN1)). _
                    Interior.Color = vbYellow
             vColored = False
        Next vN3
    Next vN1
  
End Sub
Click to expand...
Thank you. Is there any way for it to only highlight only the rows where the duplicates occur in the entire range? For instance, in the example below, Lisa is correctly highlighted for the range i selected of B:F but the following EEs shouldn't be as D:F isn't duplicated for them. Again, i get this is a tall task from what i imagine but thought I would ask. And yes, it does hang if i select the entire column. If i Ctrl Shift down and over to just the data contained in those columns, the code is pretty much instant.

Client IDWorker IDWorker NameWorkedTime PeriodCheck DateTAX | Income Tax WithheldTAX | Social Security
9989270Callanan, LisaFederalCheck Date - Qtr 307.02.202153.0862
9989270Callanan, LisaNYCheck Date - Qtr 307.02.202121.23
998915Henry III, JamesFederalCheck Date - Qtr 307.02.202178.0862
998915Henry III, JamesNYCheck Date - Qtr 307.02.202121.23
998936Johnson, WilliamaFederalCheck Date - Qtr 307.02.2021253.0862
998936Johnson, WilliamaNYCheck Date - Qtr 307.02.2021121.23
9989181Mason, Nell BFederalCheck Date - Qtr 307.02.202178.0862
9989181Mason, Nell BNYCheck Date - Qtr 307.02.202121.23
99896Reyes, David KFederalCheck Date - Qtr 307.02.202164.1246.5
99896Reyes, David KNYCheck Date - Qtr 307.02.202121.03
14119989346Austin, Andrew BFederalCheck Date - Qtr 307.02.20216.2
 
Upvote 0
It's very hard to understand you, but according to my experience,
I suppose you need something like this...
VBA Code: 
Sub HighLightSelectionRowsDuplicates()
    
    Dim vRng As Range
    Dim vR As Long
    Dim vC1 As Integer, vC2 As Integer
    Dim vN1 As Long, vN2 As Long, vN3 As Long, vN4 As Long
    
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Interior.Color = xlNone
    Set vRng = Selection
    vR = vRng.Rows.Count
    vC1 = vRng.Columns.Count
    vC2 = ActiveSheet.UsedRange.Columns.Count
    Set vRng2 = vRng.Resize(vR, vC2)
    vA2 = vRng2
    ReDim vA1(1 To vR, 1 To 2)
    For vN1 = 1 To vR
        For vN2 = 1 To vC2
            vS = vS & vA2(vN1, vN2)
        Next vN2
        vA1(vN1, 1) = vS
        vA1(vN1, 2) = vS
        vS = ""
    Next vN1
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA1(vN1, 1) = vA1(vN2, 2) Then
                vRng.Range(Cells(vN2, 1), Cells(vN2, vC1)). _
                    Interior.Color = vbYellow
                vColored = True
            End If
        Next vN2
        If vColored = True Then _
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC1)). _
                Interior.Color = vbYellow
            vColored = False
    Next vN1

End Sub
 
Upvote 0
Serafin54 said:
This one is just about flawless except if i select the columns themselves, the code seems to hang and i have to restart excel. I can skirt around the issue by selecting the range itself but is there a way to tell it to stop at the end of the range?
Click to expand...
As you asked to work with the selection so it's the worst idea to select entire columns ! :eek:​
As the end of the range is the end of the selection aka row #1 048 576 since Excel 2007 …​
 
Upvote 0
I guess it is a convenience issue here. Code can be modified as "If you select an entire column, just use UsedRange, or perhaps CurrentRegion".

VBA Code: 
If Selection.Rows.Count = Columns("A:A").Rows.Count Then
    Set vRng = ActiveSheet.UsedRange
Else
    Set vRng = Selection
End If

@Serafin54 You can also quickly select all connected cells by CTRL + * after selecting any cell with data.
 
Upvote 0
Also you can try this version...
VBA Code: 
Sub HighLightSelectionRowsDuplicates()
    
    Dim vRng As Range
    Dim vR As Long
    Dim vC As Integer
    Dim vN1 As Long, vN2 As Long
    Dim vColored As Boolean
    Dim vS As String
    
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Interior.Color = xlNone
    Set vRng = Selection
    vR = vRng.Rows.Count
    vC = vRng.Columns.Count
    vA1 = vRng
    ReDim vA2(1 To vR, 1 To 2)
    For vN1 = 1 To vR
        For vN2 = 1 To vC
            vS = vS & vA1(vN1, vN2)
        Next vN2
        vA2(vN1, 1) = vS
        vA2(vN1, 2) = vS
        vS = ""
    Next vN1
    For vN1 = 1 To vR - 1
        For vN2 = vN1 + 1 To vR
            If vA2(vN1, 1) = vA2(vN2, 2) Then
                vRng.Range(Cells(vN2, 1), Cells(vN2, vC)). _
                    Interior.Color = vbYellow
                vColored = True
            End If
        Next vN2
        If vColored = True Then _
            vRng.Range(Cells(vN1, 1), Cells(vN1, vC)). _
                Interior.Color = vbYellow
            vColored = False
    Next vN1

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Solved
populate dynamic list in dropdown without duplicates items based on sheet name
Replies
3
Views
154
kevin9999
K
A
  • Question
sorting duplicates Customers names by add two formulas in last column
Replies
3
Views
194
Kerryx
K
F
  • Question
Need to find and highlight values from high column which are greater than 10 times low value but on same expiry date,same strike price,same option typ
Replies
3
Views
306
etaf
etaf
P
  • Question
Apply Conditional Formatting to Duplicates: More than one condition
Replies
3
Views
372
Peter_SSs
Peter_SSs
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
341
Agnarr
Agnarr

Forum statistics

Threads
1,214,827
Messages
6,121,803
Members
449,048
Latest member
greyangel23

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top