Vba Macro Help

[Kyle96]

I am writing a macro to find duplicated values within a column, then paste the entire rows into a new sheet. I also need to delete the copied rows from the previous sheet.

Here is my macro so far:

Sub CutDuplicates()
'Updateby Extendoffice
Dim xRgS As Range
Dim xRgD As Range
Dim I As Long, J As Long
On Error Resume Next
Set xRgS = Application.InputBox("Please select the column:", "KuTools For Excel", Selection.Address, , , , , 8)
If xRgS Is Nothing Then Exit Sub
Set xRgD = Application.InputBox("Please select a desitination cell:", "KuTools For Excel", , , , , , 8)
If xRgD Is Nothing Then Exit Sub
xRows = xRgS.Rows.Count
J = 0
For I = xRows To 1 Step -1
If Application.WorksheetFunction.CountIf(xRgS, xRgS(I)) > 1 Then
xRgS(I).EntireRow.Copy
xRgS(I).EntireRow.Copy xRgD.Offset(J, 0)
J = J + 1
End If
Next
End Sub

This macro successful copies all duplicates and moves them to the designated sheet; however I am struggling to get it to also delete the dthe copied rows from the original sheet.

 

[Michael M]

Try using

For I = xRows To 1 Step -1
If Application.WorksheetFunction.CountIf(xRgS, xRgS(I)) > 1 Then
xRgS(I).EntireRow.Copy xRgD.Offset(J, 0)
[color=red]xRgS(I).EntireRow.Delete[/color]
J = J + 1
End If
Next I

 

[Kyle96]

Try using

For I = xRows To 1 Step -1
If Application.WorksheetFunction.CountIf(xRgS, xRgS(I)) > 1 Then
xRgS(I).EntireRow.Copy xRgD.Offset(J, 0)
[COLOR=red]xRgS(I).EntireRow.Delete[/COLOR]
J = J + 1
End If
Next I

I need to copy both lines of the duplicate data and remove them from the original sheet after copying them. The code you suggested only copies and removes one line of the duplicated data.

 

[Michael M]

Is the data sorted so that the dupes are together ??
That would be the most efficient way to do this !

Sub CD()
'Updateby Extendoffice
    Dim xRgS As Range
    Dim xRgD As Range
    Dim I As Long, J As Long
    On Error Resume Next
    Set xRgS = Application.InputBox("Please select the column:", "KuTools For Excel", Selection.Address, , , , , 8)
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Please select a desitination cell:", "KuTools For Excel", , , , , , 8)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For I = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(I)) > 1 Then
            Rows(I & ":" & I - 1).EntireRow.Copy xRgD.Offset(J, 0)
            Rows(I & ":" & I - 1).EntireRow.Delete
            J = J + 2
        End If
    Next
End Sub