Find dupe row, move one of them

greeting all!

ok, I feel like a total noob here but this is driving me up a wall. I have peaked around here and was not able to find something that will help...so here I am asking. (if you know of a post that will solve my question, please link me to it!)

I have a worksheet that contains some 8 columns of data. row 8 is the unique identifier. in the event there is a dupe record, the org as well as any other dupe(s) should then be moved to purgatory until someone can review them :-)

I am pretty sure I can do this with 2 loops, but was wondering if there might be another quicker way? I don't suspect I will ever have more than 400 records, but that's just a guess.

I would suggest that you use a helper formula to evaluate this. The process would be:

• Create a formula to identify the duplicates
• Your code may need to sort the list in a specific order to ensure that your helper formula is showing duplicates correctly
• Filter the list by the helper formula to show only the duplicate rows
• Copy the visible rows (excluding the headings) to a separate sheet
• Delete the visible rows (again, excluding the headings)
• Set the AutoFilter to show all records

Hi there,

Here's one possible VBA solution (one of many I'd imagine):

Code:

---

Sub Macro2()
   
    Dim lngLastRow As Long
    Dim rngCell As Range, _
        rngMyData As Range, _
        rngMyDups As Range
    Dim blnDupsExist As Boolean
    Dim strPasteSheetName As String
    lngLastRow = Sheets("Sheet1").Cells(Rows.Count, "H").End(xlUp).Row
    Set rngMyData = Sheets("Sheet1").Range("H2:H" & lngLastRow)
    blnDupsExist = False
   
    Application.ScreenUpdating = False
   
    For Each rngCell In rngMyData
        If Application.WorksheetFunction.CountIf(rngMyData, rngCell.Value) > 1 Then
            blnDupsExist = True
            If rngMyDups Is Nothing Then
                Set rngMyDups = rngCell.EntireRow
            Else
                Set rngMyDups = Union(rngMyDups, rngCell.EntireRow)
            End If
        End If
    Next rngCell
   
    If blnDupsExist = False Then
        MsgBox "There are no duplicates in the range " & rngMyData.Address & ".", vbExclamation, "My Duplicates Editor"
    Else
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        With rngMyDups
            .Copy Sheets(ActiveSheet.Name).Range("A2")
            .EntireRow.Delete xlShiftUp
        End With
        MsgBox "The duplicates have now been moved to the """ & ActiveSheet.Name & """ tab.", vbInformation, "My Duplicates Editor"
    End If
   
    Application.ScreenUpdating = True
 
End Sub

---

Regards,

Robert

Trebor76 -- Awesome. with just a few minor tweaks, it works great from what i can tell.

to be honest, i suck at using ranges and thats something i am sloooooowly working on learning how to manipulate. so with that in mind, thank you SO much for giving me an excelent example!

:thumb

I'm glad to have helped ;)