Code to Delete Duplicates After Copying To Another Sheet

Copper Contributor

Hi All,

Hope you are all well!

Background: This is my test excel sheet: sheet 1.pngThe duplicates column is created from this excel function: =IF(COUNTIF($A$2:$A2,A2)>1, "Duplicate",""). 

I will have lots of data where each row has a different email but some rows will be from the same company (eg CoA - A2 & A6). All the data is important.

Overall Aim: I would like to move all the duplicate Co A; Co B; Co C; etc rows to another sheet and then in that sheet move the duplicates into a third sheet and so on. That way I'll have sheet 1 with Co A; Co B; Co C; Co D; etc only once and the same with sheet 2 and so on (i.e. for CoA: the A2 row will be in sheet 1, A6 row will be in sheet 2, A9 row will be in sheet 3 and so on; same with CoB and CoC). In the above example, I'd end up with three sheets.

Ideally, I'd like the code to automatically create a new sheet to move duplicates to and then continue this cycle as there can be up to 70 duplicates for one "Co X" field. So I'd have 70 sheets with one instance of each Co line (all with different emails and other data).

Initial Script:

This script allows me to copy the bottom three duplicates into sheet 2, but I have to re-run the code which then takes 2 duplicates over to sheet 2, and then on the third re-run it takes the last remaining duplicate over to sheet 2. In reality, I'll have a lot more data so I'd like it to execute in one run. 

'VBA Code to move the entire row if cells in column 4 has the value Duplicate
Sub move_rows_to_another_sheet()
For Each myCell In Selection.Columns(4).Cells

'Need a for loop iteration
If myCell.Value = "Duplicate" Then
myCell.EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
myCell.EntireRow.delete
End If
Next
End Sub

Second Script:

I realised that the delete line is what is causing the problem. The first Sub copies all the duplicates over to sheet 2, in one run. However, the second sub still only deletes the bottom three duplicates and must be run a total of three times to remove the duplicates. I would prefer to run both subs in one and not have to re-run the delete Sub.

'VBA Codeto movethe entire row if cells in column 4 has the value Duplicate
Sub move_rows_to_another_sheet()
For Each myCell In Selection.Columns(4).Cells

'Need a for loop iteration
If myCell.Value = "Duplicate" Then
myCell.EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
End If
Next
End Sub
Sub delete_duplicates_in_sheet1()
For Each myCell In Selection.Columns(4).Cells

'Need a for loop iteration
If myCell.Value = "Duplicate" Then
myCell.EntireRow.delete
End If
Next
End Sub

 My next steps: 

I will be learning how to use a for loop so that I can have the delete Sub execute continuously until all duplicates have been deleted. If anyone knows a better way please let me know.

 

Any help would be greatly appreciated. :)

 

Thank you.

Kind regards,

Y

2 Replies

@YDN10 

 

Sub DellDuplicate()
 
Dim i     As Integer
Dim intLR As Integer
 
intLR = Sheets("Sheet1").Range("D65536").End(xlUp).Row
 
With Sheets("Sheet1")
  For i = 1 To intLR
 
    If InStr(1, .Cells(i, 4).Value, "Duplicate") Then
      .Cells(i, 1).EntireRow.Delete
      i = i - 1
    Else
 
    End If
 
  Next i
End With
 
End Sub

 

Forgive me if I didn't read through your text due to time constraints.

Send you this little code as I could understand it on the fly.

Maybe it helps, if not just ignore it :).

 

NikolinoDE

I know I don't know anything (Socrates)

 

Thank you NikolinoDE.

I used a counter variable in a For Next loop which is working for now. It moves duplicates to the next sheet.
Now I want to automate the new sheet's creation and automatically run the macro per new sheet until there are no sheets with duplicates.