Vba Macro Help

Kyle96

New Member
Joined
Jan 29, 2019
Messages
2
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.
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,538
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Try using

Code:
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

New Member
Joined
Jan 29, 2019
Messages
2
Try using

Code:
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

Well-known Member
Joined
Oct 27, 2005
Messages
20,538
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Is the data sorted so that the dupes are together ??
That would be the most efficient way to do this !


Code:
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
 

Forum statistics

Threads
1,136,433
Messages
5,675,825
Members
419,586
Latest member
RoteichA

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
Top