Moving the original data with the duplicate values

[rholdren]

I have found some really good info here about moving the duplicate values to another worksheet. Is it possible to move the original value with the duplicate. Example I have 6800 rows of data column D has member Ids. In some of the rows the member IDs are duplicated. Let's say I have starting in column D row 2 the number 12345 and in D3 and 4 I may have 12346 and later down the column I may have 12349 in rows 15, 16 17 When I delete an paste the rows I want D3 and D4 The first piece of data and it' duplicate to be moved. And when it reaches 12349 I want rows 15, 16, and 17 to be moved.

Any thoughts? Your help is greatly appreciated. Thanks.

 

[Fluff]

How about

Sub rholdren()
   Dim Cl As Range, Rng As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("a2", Range("a" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            If Rng Is Nothing Then Set Rng = Union(Cl, .Item(Cl.Value)) Else Set Rng = Union(Rng, Cl, .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then
      Rng.EntireRow.Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
      Rng.EntireRow.Delete
   End If
End Sub

 

[rholdren]

It left some and took some. but it left the originals in most cases.

 

[DanteAmor]

Try this, change "sheet1" and "shee2" by the names of your sheets

Sub Move_Duplicate()
    Dim h1 As Object, h2 As Object
    Dim r As Range, rango As Range
    Dim i As Long, wcont As Long
    Set h1 = Sheets("sheet1")  'sheet with original data
    Set h2 = Sheets("sheet2")  'sheet result with duplicate data
    h2.Cells.ClearContents
    Set rango = h1.Range("D2", Range("D" & Rows.Count).End(xlUp))
    For Each num In rango
        wcont = WorksheetFunction.CountIf(rango, num)
        If wcont > 1 Then
            If r Is Nothing Then
                Set r = num
            Else
                Set r = Union(r, num)
            End If
        End If
    Next
    r.Copy h2.Range("D2")
    r.EntireRow.Delete
    Set r = Nothing: Set rango = Nothing
    MsgBox "End"
End Sub

 

[Fluff]

Forgot to change the range, it should be

Sub rholdren()
   Dim Cl As Range, Rng As Range
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("[COLOR=#ff0000]D[/COLOR]2", Range("[COLOR=#ff0000]D[/COLOR]" & Rows.Count).End(xlUp))
         If Not .Exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            If Rng Is Nothing Then Set Rng = Union(Cl, .Item(Cl.Value)) Else Set Rng = Union(Rng, Cl, .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then
      Rng.EntireRow.Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
      Rng.EntireRow.Delete
   End If
End Sub