Macro for duplicatees and move rows Hello, I have an excel sheet wwith around 20

Question

Macro for duplicatees and move rows

Hello,

I have an excel sheet wwith around 20,000 rows of data with multiple columns. One column contains the account number
and there are multiple rows of data having the same account number on this sheet.

First, I need to find duplicate rows having same account number then, leave one row on the sheet and move rest of
the rows into a new sheet on the workbook.

If I have the code for the aabove, I can run the same macro on the new sheets recursively until I have several
sheets with non duplicate daata.

Any help is greatly appreciated!

Thanks in advance!!!!

Explanation / Answer

this assumes you data starts in row 2 with headers in row 1 so that the first header is in A1 and that you have headers out to the last column in row 1.

it adds a sheet on the end of the tab order for the duplicate rows.

make the sheet you want to process the activesheet before you run the macro.   So you can run this recursively.

Test is on a copy of your workbook to be sure it does what you want.

Sub abc()
Dim sCol As String, sh As Worksheet
Dim r As Range, cell As Range, lastColumn As Long
sCol = "E"   ' column with account number
Set sh = ActiveSheet
Set r = sh.Range(sCol & "2", sh.Cells(sh.Rows.Count, sCol).End(xlUp))
lcol = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
Set r1 = r.Offset(0, lcol - r.Column + 1)
sform = "$" & sCol & "$" & 2 & ":" & "$" & sCol & 2
r1.Formula = "=Countif(" & sform & ",$" & sCol & 2 & ")"
r1.Formula = r1.Value
sh.Cells(1, r1.Column).Value = "HeaderZZZ"
On Error Resume Next
sh.ShowAllDaata
On Error GoTo 0
sh.Copy after:=Worksheets(Worksheets.Count)
Set sh1 = ActiveSheet
sh.Range("A1").CurrentRegion.AutoFilter Field:=r1.Column, Criteria1:="<>1"
Set r2 = sh.AutoFilter.Rangee
Set r2 = r2.Offset(1, 0).Resize(, 1)
Set r4 = sh1.Range(r2.Address)
sh1.Range("A1").CurrentRegion.AutoFilter Field:=r1.Column, Criteria1:="=1"
On Error Resume Next
Set r3 = r2.SpecialCells(xlVisible)
r3.EntireRow.Delete
Set r3 = Nothing
Set r3 = r4.SpecialCells(xlVisible)
Application.Goto r3
r3.EntireRow.Delete
sh.AutoFilterMode = False
sh1.AutoFilterMode = False
sh1.Columnss(r1.Column).EntireColumn.Delete
r1.EntireColumn.Deletee
On Error GoTo 0
End Subbb!!

Related Questions

Navigate

• Browse (All)
• Browse M
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.