HELP! New to coding-need to split workshhet into multiple by finding a word that ends the data each time

suntreemom

New Member
Joined
Dec 18, 2013
Messages
3
Hi. I am not really a coder and this is new to me but I have an extremely large spreadsheet I need to disect into a seperate workbook for each set of data. While browsing on this forum I saw many references for splitting data, but it always split it due to a certain value in a column. My column the value is always unique, but the end of the section I need to split the data ends with
>end

<tbody>
</tbody> <colgroup> <col></colgroup>
For instance, I have 4 columns with no headers. Each value is different. It is set up like this:

<tbody></tbody>
ZAU6101G
grp=ZAU61altmin=986altmax=987
43.716667
272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end
ZAU6101H
grp=ZAU61altmin=988altmax=989
43.716667272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end
ZAU6101I
grp=ZAU61altmin=990altmax=991
43.716667272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>
I need to read the value in each Column A cell (ZAU6101G), this will become the title of my new 'workbook' after being split out. I take all the rows beneath that leading column A cell, until I find a row with >end, and copy over to the new 'workbook' and save the new workbook with the cell A title.

From the table above it would split into three worksheets- titled ZAU6101G, ZAU6101H, and ZAU6101I. The first workshhet would look like this:
ZAU6101G
grp=ZAU61altmin=986altmax=987
43.716667
272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end

<tbody>
</tbody>
The second:
ZAU6101H
grp=ZAU61altmin=988altmax=989
43.716667272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end

<tbody>
</tbody>
The third:
ZAU6101I
grp=ZAU61altmin=990altmax=991
43.716667272.116667node=CG31
43.716667272.183333node=CG32
43.783333272.183333node=CG22
43.783333272.116667node=CG21
>end

<tbody>
</tbody>
I have over 4,000 rows of data to split. Is this possible? Will excel only provide this functionality for so many rows, etc?

Thank you to anyone who can help!! I do not even know how to set up a VB script in excel so please explain like a book for dummies :(

Suntreemom
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
try this macro, change the file path of where you want the new workbooks to save

Code:
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 18/12/2013 by Abductee
'

'
Dim WB_name, TheLen
    
    Range("A1").Select
On Error GoTo endloop
Do Until ActiveCell.Value = ""

    Columns("A:A").Select
    Selection.Find(What:=">end", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
TheLen = ActiveCell.Row

    Range("A1:D" & TheLen).Select

    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Range("A1").Select
    WB_name = ActiveCell.Value
    ChDir "C:\Documents and Settings\USER\Desktop" ' change path to where you want to save files
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\USER\Desktop\" & WB_name & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False  ' change path above to where you want to save files
    ActiveWorkbook.Saved = True
    ActiveWindow.Close
    
    Rows("1:" & TheLen).Select
    Selection.Delete Shift:=xlUp

TheLen = 1
Range("A" & TheLen).Select

Loop
endloop:
End Sub

o
\__/\o
(Oo}
(=-) .===o- ~Z~A~P~
/'''''''\/U'
l l \_/
\\__)
E''''|
| ||
| || The
(__\\ Abductee
 
Upvote 0
try this macro, change the file path of where you want the new workbooks to save

Code:
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 18/12/2013 by Abductee
'

'
Dim WB_name, TheLen
    
    Range("A1").Select
On Error GoTo endloop
Do Until ActiveCell.Value = ""

    Columns("A:A").Select
    Selection.Find(What:=">end", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
TheLen = ActiveCell.Row

    Range("A1:D" & TheLen).Select

    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Range("A1").Select
    WB_name = ActiveCell.Value
    ChDir "C:\Documents and Settings\USER\Desktop" ' change path to where you want to save files
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\USER\Desktop\" & WB_name & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False  ' change path above to where you want to save files
    ActiveWorkbook.Saved = True
    ActiveWindow.Close
    
    Rows("1:" & TheLen).Select
    Selection.Delete Shift:=xlUp

TheLen = 1
Range("A" & TheLen).Select

Loop
endloop:
End Sub

o
\__/\o
(Oo}
(=-) .===o- ~Z~A~P~
/'''''''\/U'
l l \_/
\\__)
E''''|
| ||
| || The
(__\\ Abductee

Hi Abductee!! Thank you for the reply. I tried entering it and changing the path as mentioned. When i try to run this I get results, buit it only takes the first chunk of data and sends it to a new workbook. I need it do this a thousand times.

Can you help explain this to me? My steps for using your code are:
1. opened the developer tab
2. Opened visual basic
3. Selected 'View>Code'
4. Pasted your code all in one sheet
5. Changed the path
6. Saved
7. Clicked 'Run'

Is there a reason it only does to the first >end and makes a new sheet? I need it to loop through the data, maybe delete the transfered data it just moved so it doesnt see it again, or skip it, and keep searching for the next >end until it reaches the bottom row of the worksheet (43,952).

Thank you from the newbie!! Can I put a star by you or grade you somehow to let other users know how awesome you are?

Suntreemom
 
Upvote 0
Hi

It works fine for me and loops through all the >end statements creating multiple workbooks

I'm not sure how well you know vba. Can you comment out the error handler then step though the code using F8 to see where it errors for you?
 
Upvote 0
Thanks again for your help. I stepped into the code and got this far:
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 18/12/2013 by Abductee
'
'
Dim WB_name, TheLen

Range("A1").Select
'On Error GoTo endloop
Do Until ActiveCell.Value = ""
Columns("A:A").Select
Selection.Find(What:=">end", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

TheLen = ActiveCell.Row
Range("A1:D" & TheLen).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste


Then I get a runtime error '1004': Application-defined or object-defined error.

Thanks again :)
Suntreemom
 
Upvote 0
before the ActiveSheet.Paste line add Range("A1").Select

so it looks like this... maybe that will help

Code:
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 18/12/2013 by Abductee
'

'
Dim WB_name, TheLen
    
    Range("A1").Select
'On Error GoTo endloop
Do Until ActiveCell.Value = ""

    Columns("A:A").Select
    Selection.Find(What:=">end", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
TheLen = ActiveCell.Row

    Range("A1:D" & TheLen).Select

    Selection.Copy
    Workbooks.Add
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    WB_name = ActiveCell.Value
    ChDir "C:\Documents and Settings\USER\Desktop" ' change path to where you want to save files
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\USER\Desktop\" & WB_name & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False  ' change path above to where you want to save files
    ActiveWorkbook.Saved = True
    ActiveWindow.Close
    
    Rows("1:" & TheLen).Select
    Selection.Delete Shift:=xlUp

TheLen = 1
Range("A" & TheLen).Select

Loop
endloop:
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,267
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top