Move all the "Duplicate Numbers" from one sheet to another sheet

[fahadalambd]

Hi everyone,

I hope you are doing well.

Please help me to write a VBA script which will move all the "Duplicates" from "Sheet1" to "Sheet2".

NB: Just wanted to inform that the attached pic has very small data range but in my actual data sheet has more than 40,000 rows and there are so many duplicates numbers are present.

Thank you so much everyone.

Kind Regards

 

[kevin9999]

Try this:

Option Explicit
Sub fahadalambd()
    Application.ScreenUpdating = 0
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
   
    Dim Rng As Range
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1), Order1:=1, Header:=1
    Set Rng = Rng.Resize(Rng.Rows.Count + 1, 1)
   
    Dim ArrIn, ArrOut, i As Long
    ArrIn = Rng
    ReDim ArrOut(1 To UBound(ArrIn, 1) - 1, 1 To 1)
   
    For i = 2 To UBound(ArrIn, 1) - 1
        If ArrIn(i, 1) = ArrIn(i - 1, 1) Or ArrIn(i, 1) = ArrIn(i + 1, 1) Then ArrOut(i, 1) = 1
    Next i
    Ws1.Range("D1").Resize(UBound(ArrOut, 1)).Value = ArrOut
   
    Set Rng = Rng.Resize(Rng.Rows.Count - 1, 4)
    Rng.Sort Key1:=Ws1.Cells(1, 4), Order1:=1, Header:=1
    i = WorksheetFunction.Sum(Ws1.Range("D:D"))
    Set Rng = Rng.Resize(i + 1, 3)
   
    With Rng
        .Copy Ws2.Cells(1)
        .Offset(1).Resize(i).EntireRow.Delete
    End With
   
    Ws1.Range("D:D").ClearContents
    Application.ScreenUpdating = 1
End Sub

 

[fahadalambd]

Try this:

Option Explicit
Sub fahadalambd()
    Application.ScreenUpdating = 0
    Dim Ws1 As Worksheet, Ws2 As Worksheet
    Set Ws1 = Worksheets("Sheet1")
    Set Ws2 = Worksheets("Sheet2")
  
    Dim Rng As Range
    Set Rng = Ws1.Cells(1).CurrentRegion
    Rng.Sort Key1:=Ws1.Cells(1), Order1:=1, Header:=1
    Set Rng = Rng.Resize(Rng.Rows.Count + 1, 1)
  
    Dim ArrIn, ArrOut, i As Long
    ArrIn = Rng
    ReDim ArrOut(1 To UBound(ArrIn, 1) - 1, 1 To 1)
  
    For i = 2 To UBound(ArrIn, 1) - 1
        If ArrIn(i, 1) = ArrIn(i - 1, 1) Or ArrIn(i, 1) = ArrIn(i + 1, 1) Then ArrOut(i, 1) = 1
    Next i
    Ws1.Range("D1").Resize(UBound(ArrOut, 1)).Value = ArrOut
  
    Set Rng = Rng.Resize(Rng.Rows.Count - 1, 4)
    Rng.Sort Key1:=Ws1.Cells(1, 4), Order1:=1, Header:=1
    i = WorksheetFunction.Sum(Ws1.Range("D:D"))
    Set Rng = Rng.Resize(i + 1, 3)
  
    With Rng
        .Copy Ws2.Cells(1)
        .Offset(1).Resize(i).EntireRow.Delete
    End With
  
    Ws1.Range("D:D").ClearContents
    Application.ScreenUpdating = 1
End Sub

Thank you so much mate. The above script is working perfectly in the large data range as well. One more question - If possible is there any way to just COPY from "Sheet1" to "Sheet2". Sorry for asking again but it would be really appreciate if you help me. Thanks again for the help

 

[kevin9999]

If possible is there any way to just COPY from "Sheet1" to "Sheet2"

If you mean don't delete the rows after copying, then simply delete the following line from the code:

.Offset(1).Resize(i).EntireRow.Delete

 

[fahadalambd]

If you mean don't delete the rows after copying, then simply delete the following line from the code:

.Offset(1).Resize(i).EntireRow.Delete

Thank you so much mate. It is working now Appreciate for your help.

 

[kevin9999]

Happy to help & thanks for the feedback