Copy various duplicate rows to new sheet

[Stormseed]

Hi everyone

I have this code picked up from a friendly website:

Public Sub Extraction_to_new_sheets()
      
    Dim My_Range As Range
    Dim My_Cell As Variant
    Dim sh_Original As Worksheet
     
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
          
    Set sh_Original = ActiveSheet
     
    On Error Resume Next
    Sheets("TEMPXXX").Delete
    On Error GoTo 0
    Worksheets.Add
    ActiveSheet.Name = "TEMPXXX"
          
    Worksheets("Sheet1").Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Columns("A:A"), Unique:=True
     
    Set My_Range = Range("A2:A" & Range("A65536").End(xlUp).Row)
          
    For Each My_Cell In My_Range
        
        On Error Resume Next
        Sheets(My_Cell.Value).Delete 'delete if already exists
        On Error GoTo 0
        Worksheets.Add
        ActiveSheet.Name = My_Cell.Value
                 
        sh_Original.UsedRange.AutoFilter Field:=1, Criteria1:=My_Cell.Value        
        sh_Original.Cells.SpecialCells(xlVisible).Copy Destination:=Range("A1")
        Columns.AutoFit     
    Next
    
    Worksheets("TEMPXXX").Delete
    sh_Original.AutoFilterMode = False
    Set sh_Original = Nothing
     
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
     
End Sub

What the code does: This code basically copies all the duplicate records or rows (duplication based in column A) to a new sheet and renames the new sheet with that particular value.

What I need to accomplish: Can this code be modified in order for the code to make it work on more than 85000 rows ?

Well, I can see this code working excellent in situations where the number of rows is less than 5000 ! I tried to execute the code on one of my worksheets of more than 85000 rows and guess what...

my computer got hanged till death

Also, if someone can let me know the limit of making new sheets in a workbook in Excel 2007 ? I have over 9000 unique entries in the source data of over 85000 rows and I guess if I execute the above macro (after being modified) the code would try to create more than 9000 worksheets

Ooooh...this one was given to me as a challenge from my Bossy. He has poured all his arrogance on me all in one single shot

Any help in any form is greatly appreciated !

 

[Norie]

Could you please clarify what you want to do?

Are you trying to split out data based on the criteria in column A?

If so perhaps you could use something like this.

Option Explicit
Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
    
    Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on
    
    LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
    
    Set wsCrit = Worksheets.Add
    
    ' column A has the criteria eg project ref
    wsAll.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
    
    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
    
        Set wsNew = Worksheets.Add
        wsNew.Name = wsCrit.Range("A2")
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
         CopyToRange:=wsNew.Range("A1"), Unique:=False
        wsCrit.Rows(2).Delete
        
    Next I
    
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    
End Sub

Note this has no error handling like the code you've posted has.

 

[Stormseed]

hi Norie,

thanks for your reply

Yes, I would want to split out all the duplicate records based on column A in different sheets. Each batch of duplicate rows has to be copied in a different sheet from the main worksheet of 85000 rows and the sheetname has to be changed to the value of column A after the split.

would this code work for over 85000 rows ?

 

[Norie]

Well I can't rightly say since I run Excel 2000 so limited to 65536 rows.

Did you try the code?

Theoretically I can't see any problem but I've never tested it against such large data sets.

 

[Stormseed]

naah...have not tried the code yet coz I did not want my PC to get dangled again

But I guess I will have to try it out to see if it works out ! So rite now saving all my work and websites and applications which are currently running on my PC

 

[Stormseed]

hi again, Norie

I executed the code on my PC. It gave me a Debug Error on this line of code:

    Set wsAll = Worksheets("All")

I would like to clarify that my workbook currently has only one worksheet where all the data resides. All 85000 rows of data is on a single worksheet. This worksheet has duplicate values in column A repeated as many as 90 times. Some are repeated twice, some are repeated 10 times, some 25 times, and so on. Based on column A, the program would identify the duplicates and then copy each batch of the duplicate data (identifying duplicates based on Col A) into a new worksheet.

Likewise, for example, if there are 10 duplicate values, say '2340' in each row for 10 times in column A, it should pick all the rows (entire rows) where there is a value '2340' and copy them to a new worksheet with the worksheet name changed to '2340'. The code should again find all the duplicates to make another batch of duplicate values, say '3456', based on Column A. Assume that it found 6 duplicate values, and so copy all the 6 rows entirely to new worksheet and change the name of the worksheet to the value '3456'.

I hope you are clear with my requirement. Kindly let me know if still unclear and I would be glad to explain it to you again.

Thanks a million for all your kind help, Norie.

 

[VoG]

Actually you will see that Norie posted

Set wsAll = Worksheets("All") ' change All to the name of the worksheet the existing data is on

So try changing "All" to the name of your worksheet and try again.

 

[Stormseed]

Hello sir, thank you for your reply.

I would give it a shot again rite away...

 

[Stormseed]

Norie,

Yipeeeeeeeeeeeeee!!!!

The code worked fabulous and was smooth throughput the execution. Hats off to you !! You are an Angel and a Lifesaver !!!

I executed the code after making the changes which Mr.Vog suggested and it worked like a treat ! I was unable to identify what you actually meant in the commented line. I would have understood if it was written the other way around: like this:

"Change the name of the worksheet to All where the data exists". My english is not that good as you can see !

You are one of the most exceptional talent on MrExcel ! I mean you were always a Guru, nevertheless, I realized it rite now Also, I have seen your posts at Ozgrid many a times and I visit that forum very often. I aint a member at Ozgrid yet

Thank you so much, Norie. I am really obliged and I cud not describe in words how happy I am rite now

Kudos to you

 

[gajendra]

It is amazing to see information on this forum. It has been too helpful for me and I am really enjoying the VB now. I wanted learn Vb from long time and this forum helped.

What the code does: This code basically copies all the duplicate records or rows (duplication based in column A) to a new sheet and renames the new sheet with that particular value.

This code works great but the it copies information from parent tab 'Sheet1' to a specific tab but not in the same column....all the columns get mixed in new tabs. Does anyone knows what is going on in this code?
IN the parent tab i have data till column CK

OPPS I realize I can not attach the file...

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long

Set wsAll = Worksheets("Sheet1") ' change All to the name of the worksheet the existing data is on

LastRow = wsAll.Range("B" & Rows.Count).End(xlUp).Row

Set wsCrit = Worksheets.Add

' column A has the criteria eg project ref
wsAll.Range("B1:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("B1"), Unique:=True

LastRowCrit = wsCrit.Range("B" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit

Set wsNew = Worksheets.Add
wsNew.Name = wsCrit.Range("B2")
wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("B1:B2"), _
CopyToRange:=wsNew.Range("B1"), Unique:=False
wsCrit.Rows(2).Delete

Next I

Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True

End Sub