Removing multiples from data

I would like to have an Excel macro which removes multiples of the same number and copies those rows over to a new sheet.  The attached file shows an example.

Row 1 is the header row
Data begins from Row 2
Macro will prompt for which Column to look in
Macro will look in Col A (in this example) of Sheet 1 for any number which occurs more than one time.  It will copy those rows and paste them in Sheet 3 starting in Row 2.    The rows which have no multiples will be pasted on Sheet 2.  Sheet 1 will retain the original data.Multiples.xlsm
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Saqib Husain, SyedEngineerCommented:
If you have 2010 then the remove duplicates feature should do all you want it to.
I don't think remove duplicates covers all that you asked but there is a way to achieve this without VBA (though you could record this as a macro as a starting point if that is important).

after making a copy of the original sheet (the copy will become your 'after macro' sheet in the example
1. choose the new sheet and Sort on the column you want to work with (make sure  'my data has headers' is checked)
2. use Highlight duplicates and choose a colour (pale red is default)
3. select the whole table and turn on autofilter
4. Filter the target column on colour - choosing the pale red
5. Select the resulting set and press ALT+; then COPY to another sheet (your multiples sheet)
6. return to the copied sheet and press Del (removing the multiples you just copied)
7. Clear the autofilter
8. Resort the table without the duplicated sets
9. Delete the blank rows
ParaGlowAuthor Commented:
Thanks for the comments.  It is good to know the manual method but I rather have code which I can execute at the press of a button and have the process done in seconds.
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try this to see if this is what you are trying to achieve..

Sub CopyUniqueRecordsOnly()
Dim Col As Long, lr As Long, i As Long
Dim cell As Range
Dim Sum As String
Set cell = Application.InputBox(prompt:="Please select a cell in the target column for finding unique records.", Title:="Select The Colunm!", Type:=8)
Col = cell.Column
lr = Sheet1.Cells(Rows.Count, Col).End(xlUp).Row
If Sheet2.UsedRange.Rows.Count > 1 Then
End If
With Sheet1
   For i = 2 To lr
      If WorksheetFunction.CountIf(Sheet1.Columns(Col), Sheet1.Cells(i, Col)) = 1 Then
         Sheet1.Cells(i, Col).EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
      End If
   Next i
End With
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Sum = "SUM(A2:A" & lr - 1 & ")"
Sheet2.Cells(lr, 1).Formula = "=" & Sum
MsgBox "All the unique records are copied to the Sheet2 successfully.", vbInformation, "Done!"
End Sub

Open in new window

Click on the button on Sheet1 to get the desired output on Sheet2.
ParaGlowAuthor Commented:
SK, macro appears to work.  I also needed the "multiples" rows copied over to Sheet3.  I don't think your code does that as yet.  Thanks.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Here it is....

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.