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]

gajendra

As far as I know that code shouldn't do that and there's definitely no code to specifically move columns.

All it is doing is automating Data>Filter>Advanced... and I don't think I've ever seen the filter move columns about.

 

[Legacy 14611]

This looked like a fun kind of problem.

I don't think advanced filter is is always the fastest approach with a lot of data.

You might just be interested to try

Sub stormseedstuff()
Application.ScreenUpdating = 0
Dim v As Integer, a, b, i As Long, n As Long, m As Integer
Set a = Sheets("Sheet1").UsedRange
n = a.Rows.Count: m = a.Columns.Count
b = a.Value
a.Sort [a1]
Set a = a.Resize(n + 1)
For i = 1 To n
    If Not a(i, 1) = a(i + 1, 1) Then
        Sheets.Add.Name = a(i, 1)
        Sheets("Sheet1").Cells(v + 1, 1).Resize(i - v, m).Copy Cells(1, 1)
        v = i
    End If
Next i
a.Resize(n, m) = b
Application.ScreenUpdating = 1
End Sub

With Ecxel 2007 you're probably only limited in practice by your computer's memory, with earlier versions the number of rows may impose a lower limit.

 

[gajendra]

Rugila and Norie:

Thouand thanks for your feedback. Rugila, that code works very smooth. I was struggking too much with it. This is going to help me a lot. Thanks a lot to you guys and hats off for your knowledge.

Gajendar

 

[gajendra]

Rugila and Norie you guys are great,..
Thanks for your help earlier. I am fighting to get this simple macro to work with no luck. There are 2 tabs in attached file. I want the macro
1. to compare the values in all of column B (sheet1) with 10. If the value is less than 10 then copy the corresponding value in column A (same row) and paste it in tab 'Sheet2' in next available row. Do this for entire column B.
2. I want to repeat this process for column D, F, H, J with a loop. (i.e. compare value in column D to column C, compare value in column F with column E and so on)
Any help regarding this will be appreciated.

 

[Legacy 14611]

Try a new thread, being as explicit as you can about just what you want.