Excel 2010 VBA - MOVE duplicate rows in SHEET 1 to SHEET2

I have names in column A which have been sorted.  There is also data in cols b, c, d, etc.
I now see that I have duplicates in column A.  I would like to have VBA:
1.  Select BOTH duplicate entries (i.e. the complete rows) in SHEET 1
2.  Cut the two rows
3.  Paste them to SHEET 2 (cell A1).
4. Go back to sheet 1 and delete the now empty two rows,
5. Find for the next two duplicate entries in column A,
6. Cut  those two rows
7. Paste them to sheet2 directly underneath the rows I pasted a moment ago.
Who is Participating?
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.

Can you only have duplicates, or can there be triplicates or more?
Martin LissOlder than dirtCommented:
Sub RemoveDupes()
Dim lngLastRow As Long
Dim lngRow As Long
Dim strOldValue As String
Dim lngFirstRow As Long
Dim lngLastCol As Long
Dim bFirst As Boolean
Dim intRowCount As Integer

lngLastRow = Range("A65536").End(xlUp).Row
lngLastCol = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column

strOldValue = Range("A1").Value
bFirst = True
lngFirstRow = 1

Application.ScreenUpdating = False

For lngRow = 1 To lngLastRow + 1
    Select Case True
        Case Cells(lngRow, 1).Value <> strOldValue
            If intRowCount > 1 Then
                Range(Cells(lngFirstRow, 1), Cells(lngRow - 1, lngLastCol)).EntireRow.Cut
                With Sheets("Sheet2")
                    If Not bFirst Then
                        .Range("A" & .UsedRange.Rows.Count + 1).Select
                        bFirst = False
                    End If
                    strOldValue = Cells(lngRow, 1).Value
                    lngFirstRow = lngRow
                    intRowCount = 0
                End With
                strOldValue = Cells(lngRow, 1).Value
                lngFirstRow = lngRow
                intRowCount = 0
            End If
    End Select
    intRowCount = intRowCount + 1

For lngRow = lngLastRow To 1 Step -1
    If Cells(lngRow, 1).Value = "" Then
        Cells(lngRow, 1).EntireRow.Delete
    End If

Application.ScreenUpdating = True
End Sub

Open in new window


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
Martin LissOlder than dirtCommented:
Did that work for you?
brothertruffle880Author Commented:
Absolutely perfect.  Thanks!!!
Martin LissOlder than dirtCommented:
You're welcome and I'm glad I was able to help.

Marty - MVP 2009 to 2013
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.