Splitting Excel file into many workbooks

  • Thread starter Thread starter deepaj87
  • Start date Start date
D

deepaj87

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!!
 
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").Select
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!
 
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.
 
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.
Click to expand...

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?
 
I have no idea. I don't speak the XML stuff.

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?
Click to expand...
 
You must log in or register to reply here.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel Copy cells from one worksheet to another workseet - increment row & do again 0
VBA set thick borders around non empty cells in range 0
How to reference a cell from anther workbook without opening it 0
Copying cells from one workbook to another with many sheets 2
Combine three InputBoxes into one? 7
VBA code for pasting links -- modifying RDB code for summary workbook 10
Import multiple workbooks to current workbook in specified row number 0
Automatically compiling many workbooks into one 1

Back
Top