Move duplicates rows above-CodePudding

I have sheet1 and sheet10 to run a macro to find duplicates comparing column A and B. Highlight color duplicates, in column A move duplicates to first row A1.

enter image description here

Any help will appreciate, thank you in advance.

Macro need to run in sheet 1 and sheet 10 maybe less sheets.

Sub sbFindDuplicatesInColumn()
    Dim lastRow As Long
    Dim matchFoundIndex As Long
    Dim iCntr As Long
    lastRow = Range("A1:C").End(xlUp).Row

    For iCntr = 1 To lastRow
    If Cells(iCntr, 1) <> "" Then
        matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
        If iCntr <> matchFoundIndex Then
            Cells(iCntr, 2) = "Duplicate" 
       End If
    End If
    Next
End Sub

CodePudding user response：

You should add comparing the values of ranges

Sub sbFindDuplicatesInColumn()
    Dim lastRow As Long
    Dim matchFoundIndex As Long
    Dim iCntr As Long
    lastRow = Range("A1:C").End(xlUp).Row

    For iCntr = 1 To lastRow
    If Cells(iCntr, 1) <> "" Then
        matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
        If iCntr <> matchFoundIndex AND Cells(iCntr,1).Value <> Range("A1:A" & lastRow).Value
Then
            Cells(iCntr, 2) = "Duplicate" 
       End If
    End If
    Next
End Sub

CodePudding user response：

Build a range of the duplicate cells using Union, copy and insert them in the first row and then delete them.

Sub sbFindDuplicatesInColumn2()

    Const DUP_COLOR = &H9696FF  ' pink
    
    Dim ws, rngDup As Range, c As Range
    Dim arC, v, sht, lastRow As Long, n As Long
    
    For Each sht In Array("Sheet1", "Sheet10")
        Set ws = Sheets(sht)
        n = 0
        With ws
           
            .Cells.ClearFormats
            
            lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
            arC = .Range("C1:C" & lastRow) ' array
        
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            For Each c In .Range("A1:A" & lastRow)
                v = Application.Match(c.Value2, arC, 0)
                If Not IsError(v) Then
                
                    .Cells(v, "C").Interior.Color = DUP_COLOR
                    If n = 0 Then
                        Set rngDup = c
                    Else
                        Set rngDup = Application.Union(rngDup, c)
                    End If
                    n = n   1
                   
                End If
            Next
            
            ' move cells and sort
            If n > 0 Then
                ' copy to top
                .Range("A1").Resize(n).Insert shift:=xlDown
                rngDup.Copy .Range("A1")
                 .Range("A1:A" & n).Interior.Color = DUP_COLOR
                ' delete
                rngDup.Delete shift:=xlUp
                ' sort
                With .Sort
                    .SetRange ws.Range("A1:A" & n)
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With
            End If
        End With
        
        MsgBox n & " Duplicates found in " & ws.Name, vbInformation
    Next
End Sub