PDA

View Full Version : Find dupe row, move one of them



wolf.stalker
09-09-2010, 04:32 PM
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.

geekgirlau
09-09-2010, 07:18 PM
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

Trebor76
09-09-2010, 07:54 PM
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

wolf.stalker
09-10-2010, 09:41 AM
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

Trebor76
09-10-2010, 03:22 PM
I'm glad to have helped ;)