• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 231
  • Last Modified:

Excel - List filter out duplicate and keep highlighted

Hello experts,

I have a list from 2 users with duplicate items.  Both users had highlighted each row that they had finished working on.  I want to take the 2 list and combine it together and filter out any duplicates.  The one that are highlighted supersede the one that is not highlighted.  So remove the non-highlight if it's not duplicate.

Also would like to highlight all highlighted rows yellow.  Right now it's a mix of diffferent highlights.

Someone here helped me with some code behind that did something similar, but now I need it to do the above.

Can someone help me and see if it's possible to do that?  I want both worksheet combine, remove any duplicate with exception of highlighted item superseded non-highlight, and then finally to mark all highlighted row to yellow.

See attachment example and code.

 Book1.xls Book1.xls
Sub COPY()
 Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastRow As Long, ws2LastRow As Long, ws3LastRow As Long
    Dim Rng As Range
    
    Set ws1 = Sheets("FILTERED")
    Set ws2 = Sheets("JOHN")
    Set ws3 = Sheets("BOB")
    
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws2LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
    ws3LastRow = ws3.Range("A" & Rows.Count).End(xlUp).Row
    
    With ws2
        For i = 2 To ws2LastRow
            If .Range("A" & i).Interior.ColorIndex > 0 Then
                If Rng Is Nothing Then
                    Set Rng = .Rows(i)
                Else
                    Set Rng = Union(Rng, .Rows(i))
                End If
            End If
        Next
    End With
    
    'COMMENT OUT SINCE THIS ONLY GRAB HIGHLIGHTED ITEMS AND NEED ALL
    'If Not Rng Is Nothing Then
    '    Rng.copy
    '    ws1.Range("A" & ws1LastRow).PasteSpecial xlPasteAll
    '    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    'End If
    
    Set Rng = Nothing
    
    With ws3
        For i = 2 To ws3LastRow
            If .Range("A" & i).Interior.ColorIndex > 0 Then
                If Rng Is Nothing Then
                    Set Rng = .Rows(i)
                Else
                    Set Rng = Union(Rng, .Rows(i))
                End If
            End If
        Next
    End With
    
    'COMMENT OUT SINCE THIS ONLY GRAB HIGHLIGHTED ITEMS AND NEED ALL
    'If Not Rng Is Nothing Then
    '    Rng.copy
    '    ws1.Range("A" & ws1LastRow).PasteSpecial xlPasteAll
    '    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    'End If
    
    With ws1
        .Columns("B:F").Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        For i = ws1LastRow To 2 Step -1
            If .Range("B" & i).Value = .Range("B" & i - 1).Value And _
            .Range("C" & i).Value = .Range("C" & i - 1).Value And _
            .Range("D" & i).Value = .Range("D" & i - 1).Value Then
                .Rows(i).Delete shift:=xlUp
            End If
        Next i
    End With
End Sub

Open in new window

0
holemania
Asked:
holemania
  • 4
  • 2
  • 2
2 Solutions
 
holemaniaAuthor Commented:
I can probably combined both worksheet together and then just do a filter list the last code?  

 With ws1
        .Columns("B:F").Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        For i = ws1LastRow To 2 Step -1
            If .Range("B" & i).Value = .Range("B" & i - 1).Value And _
            .Range("C" & i).Value = .Range("C" & i - 1).Value And _
            .Range("D" & i).Value = .Range("D" & i - 1).Value Then
                .Rows(i).Delete shift:=xlUp
            End If
        Next i
    End With


Just not sure how to set it so that highlighted rows stay and non-highlighted rows that is duplicate remove.
0
 
krishnakrkcCommented:
Hi,

This goes in a standard module. Adjust the range.

Kris
Dim dic         As Object
Dim k(), n      As Long
Dim Highlight() As String
Dim txt         As String
Dim j           As Long
Dim UB          As Long
    
Sub kTest()
    
    Dim MySheets
    Dim i   As Long, r As Long
    Dim wksDest As Worksheet
    Dim ylwClr  As Long
    
    ylwClr = 65535
    
    UB = 4 'output column count(including sheet name)
    
    MySheets = Array("john", "bob") 'adjust to suit
    
    Set wksDest = Worksheets("Filtered") 'adjust to suit
    
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = 0 To UBound(MySheets)
        r = r + Worksheets(MySheets(i)).UsedRange.Rows.Count
    Next
    
    ReDim k(1 To r, 1 To UB)
    
    For i = 0 To UBound(MySheets)
        GetHighlightedValues Worksheets(MySheets(i))
    Next
    
    If Len(txt) > 1 Then
        j = j + 1
        ReDim Preserve Highlight(1 To j)
        Highlight(j) = Mid$(txt, 2)
        txt = vbNullString
    End If
    
    With wksDest
        .Range("a1").Resize(, UB - 1).Value = Worksheets(MySheets(0)).Range("a1").Resize(, UB - 1).Value
        .Range("a1").Offset(, UB - 1).Value = "Edit By"
        .Range("a2").Resize(n, UB).Value = k
        For i = 1 To j
            For r = 0 To UB - 1
                .Range(CStr(Highlight(i))).Offset(, r).Interior.Color = ylwClr
            Next
        Next
    End With
    
End Sub
Private Sub GetHighlightedValues(ByRef Sht As Worksheet)
    Dim noColor As Long
    Dim ka, t()
    Dim i       As Long
    Dim c       As Long
    Dim UB1     As Long
    Dim UB2     As Long
    
    noColor = 16777215
    
    
    ka = Sht.UsedRange.Resize(, 3) '3 column data
    UB1 = UBound(ka, 1)
    UB2 = UBound(ka, 2)
    
    For i = 2 To UB1
        If Not dic.exists(Trim$(ka(i, 1))) Then
            n = n + 1
            For c = 1 To UB2: k(n, c) = ka(i, c): Next
            k(n, 4) = Sht.Name
            dic.Add Trim$(ka(i, 1)), Array(n, UB)
            If Sht.Cells(i, 1).Interior.Color <> noColor Then
                txt = txt & "," & Cells(n + 1, 1).Address(0, 0)
                If Len(txt) > 245 Then
                    j = j + 1
                    ReDim Preserve Highlight(1 To j)
                    Highlight(j) = Mid$(txt, 2)
                    txt = vbNullString
                End If
            End If
        Else
            t = dic.Item(Trim$(ka(i, 1)))
            If Sht.Cells(i, 1).Interior.Color <> noColor Then
                txt = txt & "," & Cells(t(0) + 1, 1).Address(0, 0)
                If Len(txt) > 245 Then
                    j = j + 1
                    ReDim Preserve Highlight(1 To j)
                    Highlight(j) = Mid$(txt, 2)
                    txt = vbNullString
                End If
            End If
        End If
    Next
    
End Sub

Open in new window

0
 
SiddharthRoutCommented:
>>>Someone here helped me with some code behind that did something similar, but now I need it to do the above.

That seems to be me :)

Gimme few moments :)

Sid
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
SiddharthRoutCommented:
Oops, krishnakrkc:

Didn't see your reply.

Sid
0
 
krishnakrkcCommented:

No worries :)

0
 
SiddharthRoutCommented:
Not For Points.

Here is my version.

Sub COPY()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastRow As Long, ws2LastRow As Long, ws3LastRow As Long
    Dim Rng As Range
    
    Set ws1 = Sheets("FILTERED")
    Set ws2 = Sheets("JOHN")
    Set ws3 = Sheets("BOB")
    
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws2LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
    ws3LastRow = ws3.Range("A" & Rows.Count).End(xlUp).Row
    
    ws2.Range("A2:D" & ws2LastRow).COPY ws1.Range("A" & ws1LastRow)
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws3.Range("A2:D" & ws3LastRow).COPY ws1.Range("A" & ws1LastRow)
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    With ws1
        .Columns("A:F").Sort , Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        For i = ws1LastRow To 2 Step -1
            If .Range("B" & i).Value = .Range("B" & i - 1).Value And _
            .Range("C" & i).Value = .Range("C" & i - 1).Value Then
                If (.Range("B" & i).Interior.ColorIndex > 0 And _
                .Range("B" & i - 1).Interior.ColorIndex = -4142) Or _
                (.Range("B" & i).Interior.ColorIndex = -4142 And _
                .Range("B" & i - 1).Interior.ColorIndex = -4142) Then
                    .Rows(i - 1).Delete shift:=xlUp
                ElseIf .Range("B" & i).Interior.ColorIndex = -4142 And _
                .Range("B" & i - 1).Interior.ColorIndex > 0 Then
                    .Rows(i).Delete shift:=xlUp
                End If
            End If
        Next i
    End With
End Sub

Open in new window


Sid
0
 
SiddharthRoutCommented:
A very minute change.

Sub COPY()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim ws1LastRow As Long, ws2LastRow As Long, ws3LastRow As Long
    Dim Rng As Range
    
    Set ws1 = Sheets("FILTERED")
    Set ws2 = Sheets("JOHN")
    Set ws3 = Sheets("BOB")
    
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws2LastRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
    ws3LastRow = ws3.Range("A" & Rows.Count).End(xlUp).Row
    
    ws2.Range("A2:D" & ws2LastRow).COPY ws1.Range("A" & ws1LastRow)
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws3.Range("A2:D" & ws3LastRow).COPY ws1.Range("A" & ws1LastRow)
    ws1LastRow = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
    
    With ws1
        .Columns("A:F").Sort , Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        For i = ws1LastRow To 2 Step -1
            If .Range("B" & i).Value = .Range("B" & i - 1).Value And _
            .Range("C" & i).Value = .Range("C" & i - 1).Value Then
                If (.Range("B" & i).Interior.ColorIndex > 0 And _
                .Range("B" & i - 1).Interior.ColorIndex = -4142) Or _
                (.Range("B" & i).Interior.ColorIndex = _
                .Range("B" & i - 1).Interior.ColorIndex) Then
                    .Rows(i - 1).Delete shift:=xlUp
                ElseIf .Range("B" & i).Interior.ColorIndex = -4142 And _
                .Range("B" & i - 1).Interior.ColorIndex > 0 Then
                    .Rows(i).Delete shift:=xlUp
                End If
            End If
        Next i
    End With
End Sub

Open in new window


Sid
0
 
holemaniaAuthor Commented:
Thanks guys.  Both examples help a lot.  I was able to take it and tweak it to work for me.
0

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

  • 4
  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now