Unable to Paste Duplicate values in a new excel sheet within the same excel workbook

Hello,

Greetings!

I have been working on a VBA code where there are more than 33,000 rows of data. I have been trying to find the duplicate entries, copy and paste those duplicates in a new defined sheet "Duplicates" and then delete them from raw sheet "Raw Data". My code is running fine when run manually in the module but when I click on a button to run this code, nothing gets pasted in "Duplicates" sheet. The duplicate data gets deleted but it doesn't paste anything in the "Duplicates" sheet. Any leads will be much appreciated. Please note: since my data is huge, that is why I have used a loop here. Attached is just a dummy book.

I have attached a sample dummy report. Here is the code that I have drafted:

Set main_wbk = Workbooks("Book1.xlsx")
Set main_sht = main_wbk.Sheets("Raw Data")

main_sht.Activate 'find duplicates in column A, colour as yellow

For iCntr = 1 To lastRow2
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), range("A1:A" & lastRow2), 0)
If iCntr <> matchFoundIndex Then
Cells(iCntr, 2).Interior.Color = vbYellow
End If
End If
Next

With main_sht 'copy yellow colour in column B and copy and paste in duplicate sheet

main_sht.AutoFilterMode = False
main_sht.range("a1:bp1").AutoFilter Field:=2, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
main_sht.range("a1:bp" & lastRow).SpecialCells(xlCellTypeVisible).Copy

End With

main_wbk.Worksheets("Duplicates").range("a1").PasteSpecial

main_sht.range("a2:bp" & lastRow2).SpecialCells(xlCellTypeVisible).EntireRow.Delete 'remove duplicates

I think you just need to add this line in the beginning of the sub :

Please Login or Register  to view this content.

And change the lastRow in this line :

Please Login or Register  to view this content.

to

Please Login or Register  to view this content.