Thanks Thanks:  0
Likes Likes:  0
Page 1 of 2 12 LastLast
Results 1 to 10 of 15

Thread: Copy various duplicate rows to new sheet

  1. #1
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Red face Copy various duplicate rows to new sheet

    Hi everyone

    I have this code picked up from a friendly website:

    Code:
    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 !

  2. #2
    Board Regular Norie's Avatar
    Join Date
    Apr 2004
    Location
    Stirling, Scotland
    Posts
    74,877
    Post Thanks / Like
    Mentioned
    57 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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.
    Code:
    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.
    If posting code please use code tags.

  3. #3
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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 ?

  4. #4
    Board Regular Norie's Avatar
    Join Date
    Apr 2004
    Location
    Stirling, Scotland
    Posts
    74,877
    Post Thanks / Like
    Mentioned
    57 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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.
    If posting code please use code tags.

  5. #5
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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

  6. #6
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    hi again, Norie

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

    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.

  7. #7
    MrExcel MVP VoG's Avatar
    Join Date
    Jun 2002
    Location
    127.0.0.1
    Posts
    63,651
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    8 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    Actually you will see that Norie posted

    Code:
    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.

  8. #8
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    Hello sir, thank you for your reply.

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

  9. #9
    Banned
    Join Date
    Sep 2006
    Location
    Bombay, India
    Posts
    3,274
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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

  10. #10
    New Member
    Join Date
    Apr 2009
    Posts
    11
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Copy various duplicate rows to new sheet

    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

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •