Split & Copy Groups/Segments Based On Cell Value In Column

[Gutray]

Hi,

This is my first post but I have been using Ozgrid for awhile now. I am farily good with excel formulas but have just started with macros so bear with me if i dont understand what you mean at first.

I am looking for a way to copy rows our of sheet2 in the attached sheet based on the value in the segments column in sheet 2. The rows need to be paste into sheet3 (already has heading set up). The segments value is the number of times i need each row copied into the next sheet. The purpose of this is to split random length samples into 10cm incriments for study. For example, a 1.5m sample is taken so there should be 15 segments of 10cm each copied into sheet3.

Also, if possible, it would be nice for it to display the actual length of the segment after copied into sheet3 for cases where the length was not evenly divisible by 10. I have found several examples of row copying macros, but none that will copy a conditional number of hte same row based on a cell value. In the original data there are close to 4000 rows, but the number of rows will vary depending on the data source.

Another thought I had was if the total number of available rows is going to be exceded would it be possible to have the rows pasted into different sheets based on the rock type listed in the column?

Thanks in advance for your help

[Ger Plante]

This will split the segments based on the value in Column U in sheet 2 and copy them into Sheet 3. I dont understand the other columns to the right of column S on sheet 3 (U,W,X,Y), so these are left blank.

Option Explicit 
 
Public Sub split_segments() 
     
    Dim my_cell As Variant 
    Dim l_Loop As Long 
    Dim l_loop2 As Long 
     
    Application.Calculation = xlManual 
    Application.EnableEvents = False 
    Application.ScreenUpdating = False 
     
    Worksheets("Sheet3").Rows("7:" & Rows.Count).Delete 
     
    With Worksheets("Sheet2") 
        For l_Loop = 9 To .Range("B" & .Rows.Count).End(xlUp).Row 'start on row 9
            Worksheets("Sheet3").Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(.Range("U" & l_Loop), 18).Value = _ 
            .Range("B" & l_Loop & ":S" & l_Loop).Value 
        Next 
    End With 
     
    Application.Calculation = xlAutomatic 
    Application.EnableEvents = True 
    Application.ScreenUpdating = True 
     
End Sub 

A small note - it is probably wiser to WinZip... I think less people have access to WinRAR...

Run Macro called "Split_Segments"

Ger

[Gutray]

Ger,
Tha works well but when I put in all of the data I am getting a error message:
Run-time error '1004':

Application-defined or object-defined error

Is it possible this error is because there is more data than rows?

then it is highlighting

Worksheets("Sheet3").Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(.Range("U" & l_Loop), 18).Value = _ 
.Range("B" & l_Loop & ":S" & l_Loop).Value 

I was looking at the article on creating a worksheet for each item in a list and was thinking that could solve this problem, if it is the number of rows causing this error.

Thanks

[Ger Plante]

Yes, thats certainly possible alright, in fact, if your data is following the same structure, you should be able to tell in advance if that IS the case. i.e. the segment numbers in COlumn U on Sheet 2 represent the number of times that that row will be copied. Therefore if you add all the numbers in Column U Row 9 to the bottom (use a simple sum formula at the end of the column), then this will indicate to you the number Rows that will be created in Sheet 3. If this sum is > 65536 then yes, you will have a problem creating blocks of segments the size of which is indicated in Column U. Additionally when the code crashes, it should have more or less filled Sheet 3 as requested... so if you scroll down to the last row of data on Sheet 3 and its close to row 65,000, then this too would indicate you have run out of Rows!

You could create a new worksheet for each segment block, but that would probably be a pain and you are also likely to run out of worksheet space pretty quickly too...

If you are on Excel 2007, the Row limitation shouldnt be a problem (over a million rows), but the worksheet would become unmanagable / unusable because you have several calls to a fairly complicated User Defined function in column S and R (if memory serves me right). That would slow down your worksheet.

Depending on what exactly you want to do with the blocks of repeating data, you may be better off with a Pivot table... just a thought.

Anyway, do me a favour and add up the numbers in Column U... it may not be a case that you have run out of Rows at all and it may well be the case that my code was just a pile of...

Ger

[Gutray]

Yeah,
I double checked and sheet 3 was filled to about 5 rows from the bottom, i have 2007 at home, but not here so i have to keep it all in 2003 format . What we are doing is breaking all the random intervals down into 10cm blocks, then recompiling them into 10-20m increments by rock type. The reason that we go down to 10cm intervals is that we can justify throwing out 10cm intervals, but could not justify trashing a 1.5-3m interval.

What I have been playing with is combining your macro with this

Sub PagesByDescription() 
    Dim rRange As Range, rCell As Range 
    Dim wSheet As Worksheet 
    Dim wSheetStart As Worksheet 
    Dim strText As String 
     
    Set wSheetStart = ActiveSheet 
    wSheetStart.AutoFilterMode = False 
     'Set a range variable to the correct item column
    Set rRange = Range("A1", Range("A65536").End(xlUp)) 
     
     'Delete any sheet called "UniqueList"
     'Turn off run time errors & delete alert
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Worksheets("UniqueList").Delete 
     
     'Add a sheet called "UniqueList"
    Worksheets.Add().Name = "UniqueList" 
     
     'Filter the Set range so only a unique list is created
    With Worksheets("UniqueList") 
        rRange.AdvancedFilter xlFilterCopy, , _ 
        Worksheets("UniqueList").Range("A1"), True 
         
         'Set a range variable to the unique list, less the heading.
        Set rRange = .Range("A2", .Range("A65536").End(xlUp)) 
    End With 
     
    On Error Resume Next 
    With wSheetStart 
        For Each rCell In rRange 
            strText = rCell 
            .Range("A1").AutoFilter 1, strText 
            Worksheets(strText).Delete 
             'Add a sheet named as content of rCell
            Worksheets.Add().Name = strText 
             'Copy the visible filtered range _
            (default of Copy Method) And leave hidden rows 
            .UsedRange.Copy Destination:=ActiveSheet.Range("A1") 
            ActiveSheet.Cells.Columns.AutoFit 
        Next rCell 
    End With 
     
    With wSheetStart 
        .AutoFilterMode = False 
        .Activate 
    End With 
     
    On Error Goto 0 
    Application.DisplayAlerts = True 
End Sub 

from http://www.ozgrid.com/VBA/item-worksheets.htm

and setting up a worksheet (or possibly a separate work book to keep the size down) for each rock type. Since ultimately we only look at rock types individually this would work well but I was not quite how to combine these two as it seems 2 different ways of pasting the data. I changed the headings around a bit in my sheet to get the code above to work in my sheet, and have been playing around (unsuccessfully) to get your code integrated. If you have any thoughts on this i would greatly appreciate it.

Thanks

[Ger Plante]

Hi Gutray, I couldnt really adapt the code with certainty because you have changed the layout of your data...

The code you provided above will create a new worksheet for a given unique value, but as I warned above somewhere you'll probably end up with a lot of worksheets...

If you can get the code working that creates a new sheet for each unique item, post a sample of data and the working code and I'll see if I can figure out how to replicate each line 'x' number of times... but it would probably invovle adapting this piece of code here:

With wSheetStart 
    For Each rCell In rRange 
        strText = rCell 
        .Range("A1").AutoFilter 1, strText 
        Worksheets(strText).Delete 
         'Add a sheet named as content of rCell
        Worksheets.Add().Name = strText 
         'Copy the visible filtered range (default of Copy Method) And leave hidden rows
        .UsedRange.Copy Destination:=ActiveSheet.Range("A1") 
        [COLOR="Red"] 'create copies of the record on the activesheet
        ActiveSheet.Rows(1).Copy Destination:=ActiveSheet.Rows("2:10") 'for example - the 2:10 refers to the number of rows and that would need to be changed....[/COLOR]
        ActiveSheet.Cells.Columns.AutoFit 
    Next rCell 
End With 

Alternatively, you could split your data on Sheet 2 manually into 2 or 3 sheets to ensure you dont run over the 65536 limit and run my macro on each sheet...

HTH
Ger

[Gutray]

Ok, here is how i changed the data, I had to restructure the headings to get the advanced filter to work. The code to create the sheets is here:

 'Create Sheets Named After Rock Rock Types
Public Sub Strata() 
     
    Dim rRange As Range, rCell As Range 
    Dim wSheet As Worksheet 
    Dim wSheetStart As Worksheet 
    Dim strText As String 
     
    Set wSheetStart = ActiveSheet 
    wSheetStart.AutoFilterMode = False 
     'Set a range variable to the correct item column
    Set rRange = Range("A6", Range("A65536").End(xlUp)) 
     
     'Delete any sheet called "Strata"
     'Turn off run time errors & delete alert
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Worksheets("Strata").Delete 
     
     'Add a sheet called "Strata"
    Worksheets.Add().Name = "Strata" 
     
     'Filter the Set range so only a unique list is created
    With Worksheets("Strata") 
        rRange.AdvancedFilter xlFilterCopy, , _ 
        Worksheets("Strata").Range("A1"), True 
         
         'Set a range variable to the unique list, less the heading.
        Set rRange = .Range("A2", .Range("A65536").End(xlUp)) 
    End With 
     
    On Error Resume Next 
    With wSheetStart 
        For Each rCell In rRange 
            strText = rCell 
            .Range("A6").AutoFilter 1, strText 
            Worksheets(strText).Delete 
             'Add a sheet named as content of rCell
            Worksheets.Add().Name = strText 
             
        Next rCell 
    End With 
     
    With wSheetStart 
        .AutoFilterMode = False 
        .Activate 
    End With 
     
    On Error Goto 0 
    Application.DisplayAlerts = True 
     
     
End Sub 

It will create the sheets but is not putting any data in the sheets as it sits now. Once all of this data goes into the other sheets there is a very large amount of calculations that come next, so i almost think it would be better to leave the sheets permanent, and have the code just rename them based on the unique list advanced filter creates on the "strata" sheet. That way the calculations and graphs will not have to be reconstructed or paste in.


Thanks

also, for some reason i can not get .zip files to compress smaller than .rar's this file is 42kb as a .rar and was 56kb as a .zip

---

Auto Merged Post Until 24 Hrs Passes;

Ger, do you think it would be possible to encorporate your code into the code above, since hte code above could copy each grouping into the seperate sheets, could your code copy the data the correct number of times overitself in the sheet?
For instance, once all the basalt values were put into the basalt sheet, then your code copies each row the number of times specified, but places it over the data it copied instead of into a new sheet. If this is possible I think it would be the best bet

[Ger Plante]

This appears to work...

You were setting the filter on the wrong row... your data started on Row 6, but you were filtering on Row 1....

Additionally, you werent copying any data after the filtering. I also turned off screen updating and switched calulation to manual as the screen was flashing a little bit.

Run the Macro called "Strata"

Option Explicit 
 
 'Create Sheets Named After Rock Rock Types
Public Sub Strata() 
     
    Dim rRange As Range, rCell As Range 
    Dim wSheet As Worksheet 
    Dim wSheetStart As Worksheet 
    Dim strText As String 
    Dim lLoop As Long 
    Dim Num_Rows As Long 
    Application.ScreenUpdating = False 
    Application.Calculation = xlCalculationManual 
     
    Set wSheetStart = ActiveSheet 
    wSheetStart.AutoFilterMode = False 
     'Set a range variable to the correct item column
    Set rRange = Range("A1", Range("A65536").End(xlUp)) 
     
     'Delete any sheet called "Strata"
     'Turn off run time errors & delete alert
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Worksheets("Strata").Delete 
     
     'Add a sheet called "Strata"
    Worksheets.Add().Name = "Strata" 
     
     'Filter the Set range so only a unique list is created
    With Worksheets("Strata") 
        rRange.AdvancedFilter xlFilterCopy, , _ 
        Worksheets("Strata").Range("A1"), True 
         
         'Set a range variable to the unique list, less the heading.
        Set rRange = .Range("A2", .Range("A65536").End(xlUp)) 
    End With 
     
    On Error Resume Next 
    With wSheetStart 
        For Each rCell In rRange 
            strText = rCell 
            .Range("A6").AutoFilter 1, strText 
            Worksheets(strText).Delete 
             'Add a sheet named as content of rCell
            Worksheets.Add().Name = strText 
            .UsedRange.Copy Destination:=ActiveSheet.Range("A1") 
            With ActiveSheet 
                Num_Rows = .Range("A" & .Rows.Count).End(xlUp).Row 
                For lLoop = Num_Rows To 2 Step -1 'start on last row and work backwards to row 2
                    .Range("A" & lLoop).EntireRow.Copy 
                    .Rows(lLoop + 1 & ":" & lLoop + .Range("T" & lLoop).Value - 1).Insert shift:=xlDown 
                    Application.CutCopyMode = False 
                Next 
            End With 
             
        Next rCell 
    End With 
     
    With wSheetStart 
        .AutoFilterMode = False 
        .Activate 
    End With 
     
    On Error Goto 0 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    Application.Calculation = xlCalculationAutomatic 
     
End Sub 

HTH
Ger

[Gutray]

Ger,

That works perfectly. Thanks so much for the help!

[Ger Plante]

Good, glad I was able to help...