Moving the original data with the duplicate values

rholdren

Board Regular
Joined
Aug 25, 2016
Messages
140
Office Version
  1. 365
  2. 2019
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.
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
How about
Code:
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
 
Upvote 0
Try this, change "sheet1" and "shee2" by the names of your sheets

Code:
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
 
Upvote 0
Forgot to change the range, it should be
Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,208
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top