We help IT Professionals succeed at work.

Excel - List filter out duplicate and keep highlighted

holemania
holemania asked
on
Medium Priority
252 Views
Last Modified: 2012-05-11
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

Comment
Watch Question

Author

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.
Unlock this solution and get a sample of our free trial.
(No credit card required)
UNLOCK SOLUTION
>>>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
Oops, krishnakrkc:

Didn't see your reply.

Sid

No worries :)

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
Unlock this solution and get a sample of our free trial.
(No credit card required)
UNLOCK SOLUTION

Author

Commented:
Thanks guys.  Both examples help a lot.  I was able to take it and tweak it to work for me.
Unlock the solution to this question.
Thanks for using Experts Exchange.

Please provide your email to receive a sample view!

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.