Consulting

Results 1 to 5 of 5

Thread: Find dupe row, move one of them

  1. #1

    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.

  2. #2
    Moderator VBAX Master geekgirlau's Avatar
    Joined
    Aug 2004
    Location
    Melbourne, Australia
    Posts
    1,464
    Location
    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

    We are what we repeatedly do. Excellence, therefore, is not an act but a habit.
    Aristotle

  3. #3
    Hi there,

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

    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

  4. #4
    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!


  5. #5
    I'm glad to have helped

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •