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.
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.