ExcelBanter - Splitting Excel file into many workbooks

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - Splitting Excel file into many workbooks (https://www.excelbanter.com/excel-programming/392236-splitting-excel-file-into-many-workbooks.html)

Splitting Excel file into many workbooks

Hi,

I have 1 worksheet with lots of data from different presentations.
They all end with the same cell value, which is "The information".
I am trying to write a macro that will select and cut all the cells
from below the last "the information" to the next "the information"
cell. i want it to paste in a new workbook, save & close, then go
back to the 1st workbook and repeat. Help please!!

Splitting Excel file into many workbooks

Hi

Start here
http://www.rondebruin.nl/copy5.htm

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

wrote in message ups.com...
Hi,

I have 1 worksheet with lots of data from different presentations.
They all end with the same cell value, which is "The information".
I am trying to write a macro that will select and cut all the cells
from below the last "the information" to the next "the information"
cell. i want it to paste in a new workbook, save & close, then go
back to the 1st workbook and repeat. Help please!!

Splitting Excel file into many workbooks

Hi,
I had tried that site, and it was good, except that I got stuck in
trying to tell it to come back to the 1st workbook and do it again.
Here's my code:

Sub Split_Presentations()

Dim app_path As String, dir_name As String, file_name As String, i
As Long, last_row As Integer, newCell As Long, newRow As Integer
Dim SelectedRow As Integer
Dim newInfo As String

app_path = Application.ActiveWorkbook.Path
dir_name = "\Workbooks\"
last_row = ActiveSheet.Cells.Find(what:="",
SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

Application.DisplayAlerts = False
newInfo = "The information"

For i = 1 To last_row

Set rng = ActiveSheet.Cells.Find(newInfo)
Rows(rng.Row).Activate
Set myrng = Range(Cells(ActiveCell.Row + 1, "A"), Cells(Rows.Count,
"B"))
myrng.Select
myrng.Copy
file_name = "Presentation " & i

Workbooks.Add
Workbooks(Workbooks.Count).Sheets(1).Paste
Workbooks(Workbooks.Count).Sheets(1).Range("A1").S elect
ActiveWorkbook.SaveAs Filename:=app_path & dir_name & file_name
& ".xls"
Workbooks(Workbooks.Count).Close

Exit For

Next i

End Sub

Thanks so much for your help!

Splitting Excel file into many workbooks

So if you have something like:

The Information
a
a
a
The Information
b
b
b
b
b
The Information
c
c
c
The Information
d
d
d
d
The Information
e
e
e
e
e
The Information
f
f
f
f

You'd want to generate 5 workbooks.
presentation 001.xls contains 3 rows (a, a, a)
presentation 002.xls contains 5 rows
presentation 003.xls contains 3 rows
presentation 004.xls contains 4 rows
presentation 005.xls contains 5 rows

And there would be no presentation 006 since it didn't end with "the
information". (Add that text at the bottom if you need to get the last one.)

And notice that I didn't include the "the information" lines in the resulting
workbooks.

This seemed to work ok for me:

Option Explicit
Sub Split_Presentations2()

Dim FirstFound As Range
Dim FoundCell As Range
Dim ActWks As Worksheet
Dim NewWks As Worksheet

Dim DirName As String
Dim myFileName As String
Dim iCtr As Long
Dim NewInfo As String
Dim TopCell As Range
Dim BotCell As Range

Set ActWks = ActiveSheet 'where all the data is
NewInfo = "The information"

DirName = ActiveWorkbook.Path & "\Workbooks\"
myFileName = "Presentation "
iCtr = 0

With ActWks
With .Cells 'or .Range("a:a") to check a single column
Set FoundCell = .Cells.Find(what:=NewInfo, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False)

If FoundCell Is Nothing Then
MsgBox NewInfo & " wasn't found!"
Exit Sub
End If

Set FirstFound = FoundCell
'first row to copy is under this cell with "the information"
Set TopCell = FoundCell.Offset(1, 0)
Set BotCell = Nothing
Do
Set FoundCell = .FindNext(FoundCell)

If FoundCell.Row = FirstFound.Row Then
'at the top again
Exit Do
End If

'last row to copy is above this cell with "the information"
Set BotCell = FoundCell.Offset(-1, 0)

Set NewWks = Workbooks.Add(1).Worksheets(1)
.Range(TopCell, BotCell).EntireRow.Copy _
Destination:=NewWks.Range("a1")

With NewWks.Parent
iCtr = iCtr + 1
.SaveAs Filename:=DirName & myFileName _
& Format(iCtr, "000") & ".xls"
.Close savechanges:=False
End With

'get ready for next set
Set TopCell = FoundCell.Offset(1, 0)

Loop

End With
End With

End Sub

This does assume that you don't have "the information" in multiple cells in the
same row. If you know what column that key is in, I'd use that in the .find
statement, like: With .range("a:a")

And it also assumes that there is a folder named \Workbooks\ under the folder
that holds the workbook that owns this code.

wrote:

Hi,

I have 1 worksheet with lots of data from different presentations.
They all end with the same cell value, which is "The information".
I am trying to write a macro that will select and cut all the cells
from below the last "the information" to the next "the information"
cell. i want it to paste in a new workbook, save & close, then go
back to the 1st workbook and repeat. Help please!!

--

Dave Peterson

Splitting Excel file into many workbooks

On Jun 27, 7:00 pm, Dave Peterson wrote:
So if you have something like:

The Information
a
a
a
The Information
b
b
b
b
b
The Information
c
c
c
The Information
d
d
d
d
The Information
e
e
e
e
e
The Information
f
f
f
f

You'd want to generate 5 workbooks.
presentation 001.xls contains 3 rows (a, a, a)
presentation 002.xls contains 5 rows
presentation 003.xls contains 3 rows
presentation 004.xls contains 4 rows
presentation 005.xls contains 5 rows

And there would be no presentation 006 since it didn't end with "the
information". (Add that text at the bottom if you need to get the last one.)

And notice that I didn't include the "the information" lines in the resulting
workbooks.

This seemed to work ok for me:

Option Explicit
Sub Split_Presentations2()

Dim FirstFound As Range
Dim FoundCell As Range
Dim ActWks As Worksheet
Dim NewWks As Worksheet

Dim DirName As String
Dim myFileName As String
Dim iCtr As Long
Dim NewInfo As String
Dim TopCell As Range
Dim BotCell As Range

Set ActWks = ActiveSheet 'where all the data is
NewInfo = "The information"

DirName = ActiveWorkbook.Path & "\Workbooks\"
myFileName = "Presentation "
iCtr = 0

With ActWks
With .Cells 'or .Range("a:a") to check a single column
Set FoundCell = .Cells.Find(what:=NewInfo, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlWhole, _
searchorder:=xlByRows, _
searchdirection:=xlNext, _
MatchCase:=False)

If FoundCell Is Nothing Then
MsgBox NewInfo & " wasn't found!"
Exit Sub
End If

Set FirstFound = FoundCell
'first row to copy is under this cell with "the information"
Set TopCell = FoundCell.Offset(1, 0)
Set BotCell = Nothing
Do
Set FoundCell = .FindNext(FoundCell)

If FoundCell.Row = FirstFound.Row Then
'at the top again
Exit Do
End If

'last row to copy is above this cell with "the information"
Set BotCell = FoundCell.Offset(-1, 0)

Set NewWks = Workbooks.Add(1).Worksheets(1)
.Range(TopCell, BotCell).EntireRow.Copy _
Destination:=NewWks.Range("a1")

With NewWks.Parent
iCtr = iCtr + 1
.SaveAs Filename:=DirName & myFileName _
& Format(iCtr, "000") & ".xls"
.Close savechanges:=False
End With

'get ready for next set
Set TopCell = FoundCell.Offset(1, 0)

Loop

End With
End With

End Sub

This does assume that you don't have "the information" in multiple cells in the
same row. If you know what column that key is in, I'd use that in the .find
statement, like: With .range("a:a")

And it also assumes that there is a folder named \Workbooks\ under the folder
that holds the workbook that owns this code.

wrote:

Hi,

I have 1 worksheet with lots of data from different presentations.
They all end with the same cell value, which is "The information".
I am trying to write a macro that will select and cut all the cells
from below the last "the information" to the next "the information"
cell. i want it to paste in a new workbook, save & close, then go
back to the 1st workbook and repeat. Help please!!

--

Dave Peterson

Thanks so much Dave!
That's a huge help. Is there a way to somehow get the macro to seek
the XML files as well, if they're all in groups separated by folders?
So, have the macro get the 1st file (using an XML map), edit it using
another macro, save and close, then go get the next folder?

Splitting Excel file into many workbooks