Create seprate files from multiple sheets in excel

[Shuvro Basu]

Hi All,

Here is what I need to do:

I have 2 excel workbooks. For simplicity lets assume them to be BookA
and BookB. BookA has 20 odd worksheets (say s1, s2..........s20) and
BookB has 3 sheets (say bs1,bs2 and bs3). What I need to do create a
file that has s1 from BookA and bs1 to bs3 of BookB in that order.
Hence I would have 20 files (for the 20 sheets of BookA) each with the
filename as "SomePrefix_S1.xls" ........ "SomePrefix_S20.xls".

I tried to do this but unfortunately lost my control on the code and
just too confused to know where to start again. Any help in this regard
or pointers will be highly appreciated.

Regds

 

[Guest]

Okay, you can put the following code in for example your ThisWorkbook code
module in BookA.

I just hacked it together, and I'm not yet deleting the original sheets
(Sheet1-3) in the newly generated workbooks, simply because I haven't figured
out a way to turn off Excel's warning yet (but it cannot be impossible). The
same goes for overwriting already existing workbook files (generates
warnings, must obviously be possible to turn off).

The code isn't very robust since it doesn't do any proper error checking,
but it's still okay for demo purposes, I reckon )

Of course, you should change the constants as you see fit.

HTH,
/MP

========================================

Option Explicit

Private Const BookIter As String = "BookA.xls"
Private Const BookCopy As String = "BookB.xls"

Private Const FilePath As String = "C:\tmp\"
Private Const FilePrefix As String = "split_"
Private Const FileSuffix As String = ".xls"

Private Sub SplitBooks()
Dim wbIter As Workbook
Dim wbCopy As Workbook

Set wbIter = Workbooks(BookIter)
Set wbCopy = Workbooks(BookCopy)

Dim bUpdateState As Boolean
bUpdateState = Application.ScreenUpdating
Application.ScreenUpdating = False

Dim wbNew As Workbook
Dim wsIter As Worksheet
For Each wsIter In wbIter.Worksheets
Set wbNew = Workbooks.Add
SetNewWbSheets wbNew, wsIter, wbCopy
wbNew.SaveAs GetFileName(wbNew, wsIter)
Next wsIter

Application.ScreenUpdating = bUpdateState
End Sub

Private Sub SetNewWbSheets( _
wbNew As Workbook, _
wsIter As Worksheet, _
wbCopy As Workbook)

wsIter.Copy , wbNew.Worksheets(wbNew.Worksheets.Count)

Dim ws As Worksheet
For Each ws In wbCopy.Worksheets
ws.Copy , wbNew.Worksheets(wbNew.Worksheets.Count)
Next ws

Dim i As Integer
For i = 1 To 3
' TODO:
' Still generates annoying warnings;
' but must be possible to disable?!
'wbNew.Worksheets(1).Delete
Next i
End Sub

Private Function GetFileName(wb As Workbook, ws As Worksheet) As String
GetFileName = FilePath & FilePrefix & ws.Name & FileSuffix
End Function

==============================================

 

[Guest]

And by all means, check out for example Ron de Bruin's web site with Excel
tips and tricks (the following link is in fact directly relevant to worksheet
copying):

http://www.exceltip.com/st/Copy_a_s..._folder_using_VBA_in_Microsoft_Excel/560.html

 

[mudraker]

try this code

Sub CreateWorkbooks()
Dim wS As Worksheet
Dim wbA As Workbook
Dim wbB As Workbook
Dim wbNew As Workbook
Dim sPath As String
Dim sFname As String
Dim i4Cnt As Integer

Set wbA = WorkBooks("BookA.xls")
Set wbB = WorkBooks("BookB.xls")
sPath = "D:\My Documents\"
For Each wS In Worksheets
sFname = wS.Name
wS.Copy
Set wbNew = ActiveWorkbook
For i4Cnt = 1 To wbB.Sheets.Count Step 1
wbB.Sheets(i4Cnt).Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
Next i4Cnt
wbNew.SaveAs Filename:=sPath & sFname & ".xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False _
, CreateBackup:=False
wbNew.Close
Next wS

End Sub

You can also replace my i4Cnt loop with either one of these 2 lines of
code
Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Copy
Sheets(Array(1, 2, 3)).Copy

 

[Shuvro Basu]

Hi Mat and mudraker,

I did figure out a way to do the same. Also to supress warnings just
use:
Application.DisplayAlerts = False

regds