PDA

View Full Version : Split Worksheet into separate workbooks



BBedford
03-23-2015, 07:48 AM
Hello- this is my first post and first time using VBA. So I apologize if I am using terms incorrectly. I am trying to split a workbook with 60+ tabs into separate workbooks. I am getting an error "Copy method of Worksheet class failed" . Can someone advise what I am doing incorrectly?

Sub Splitbook()
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xws In ThisWorkbook.Sheets
xws.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xws.Name & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Also, if it is possible I would like each workbook to save as name in a reference cell in that worksheet, not the tab name. Any suggestions?

thank you in advance!

mancubus
03-23-2015, 08:42 AM
welcome to vbax.

please use code tags when pasting your macros. # button in qucik reply will do it for you.

assuming A1 cells in all worksheets contain the workbook names, try:


Sub Splitbook()

Dim ws As Worksheet

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

For Each ws In ThisWorkbook.Worksheets
ws.Copy
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Range("A1") & ".xls", FileFormat:=56 '(56 = Excel8 excel file = .xls)
.Close False
End With
Next

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub

BBedford
03-24-2015, 12:14 PM
Thank you for your reply. I am now getting an error "Run-time error '1004': Method 'SaveAs' of object '_workbook' failed."

Paul_Hossler
03-24-2015, 04:25 PM
I've found that it's easier when dealing with more that one open WB, to create WB objects. It just seems to help me keep them straight

I'm assuming that you want each of the WB's created to be named as the worksheet that was copied




Option Explicit
Sub SplitSheets()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String


Set wb1 = ThisWorkbook
sPath1 = wb1.Path

Application.ScreenUpdating = False

For Each ws In wb1.Worksheets
If ws.Visible Then
ws.Copy
Set wb2 = ActiveWorkbook
sPath2 = sPath1 & Application.PathSeparator & ws.Name

On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0

Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wb2.Close(False)
End If
Next

wb1.Activate
Application.ScreenUpdating = False
End Sub

BBedford
03-25-2015, 06:33 AM
Hi Paul. The Macro worked-Thank you. I am trying to save the workbooks as a name in a reference cell "F7" in each of the workbooks. I have tried updating the code but received another error. Where should I put this reference in the code?

Paul_Hossler
03-25-2015, 06:50 AM
Hi Paul. The Macro worked-Thank you. I am trying to save the workbooks as a name in a reference cell "F7" in each of the workbooks. I have tried updating the code but received another error. Where should I put this reference in the code?



If you mean that you want the created workbooks to be named based on the F7 on each worksheet, change




sPath2 = sPath1 & Application.PathSeparator & ws.Name



to




sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text


But to handle the case where these is a error (#DIV/0! or some other problem) in F7, I added a little error handling




Option Explicit
Sub SplitSheets()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String


Set wb1 = ThisWorkbook
sPath1 = wb1.Path

Application.ScreenUpdating = False

For Each ws In wb1.Worksheets
If ws.Visible Then
ws.Copy
Set wb2 = ActiveWorkbook
sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text

On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0

On Error GoTo CanNotSaveIt
Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wb2.Close(False)



End If
Next

wb1.Activate
Application.ScreenUpdating = False

Exit Sub

CanNotSaveIt:
Call MsgBox("Can not save" & vbCrLf & vbCrLf & sPath2, vbCritical + vbOKOnly, "Split Workbook")
Resume Next
End Sub

BBedford
03-26-2015, 06:37 AM
Thank you all so much!!!! This worked like a charm and has saved me a lot of time!

dgxcook
08-16-2018, 05:53 AM
Hey Paul!

The above is exactly what I am needing.

However, I am trying to have this in my personal.xlsb file so I may use it as needed in other workbooks. When I run this from another workbook it saves copies of the worksheets in personal.xlsb.

Any advice?

Paul_Hossler
08-16-2018, 06:10 AM
Really only need one line changed (<<<<<<) but I added an error check and better variable names




Option Explicit

Sub SplitSheets()
Dim wbSource As Workbook, wbDest As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String

If ActiveWorkbook Is Nothing Then
Call MsgBox("You need an Active Workbook", vbCritical + vbOKOnly, "Split Workbook")
Exit Sub
End If

Set wbSource = ActiveWorkbook '<<<<<<<<<<<<<<<<<<
sPath1 = wbSource.Path

Application.ScreenUpdating = False

For Each ws In wbSource.Worksheets
If ws.Visible Then
ws.Copy
Set wbDest = ActiveWorkbook
sPath2 = sPath1 & Application.PathSeparator & ws.Range("F7").Text

On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0

On Error GoTo CanNotSaveIt
Call wbDest.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wbDest.Close(False)
End If
Next

wbSource.Activate
Application.ScreenUpdating = False
Exit Sub

CanNotSaveIt:
Call MsgBox("Can not save" & vbCrLf & vbCrLf & sPath2, vbCritical + vbOKOnly, "Split Workbook")
Resume Next
End Sub

dgxcook
08-16-2018, 09:00 AM
Hey Paul!

Thanks for the response. I'm now getting an error "can not save" when I try to run this.

Paul_Hossler
08-16-2018, 03:21 PM
what version of Excel?

dgxcook
08-17-2018, 06:17 AM
Office 365.

Paul_Hossler
08-18-2018, 04:56 AM
Are you using .xls or .xlsx files?

Otherwise, I can't guess why if doesn't save


Comment out the On Error and see what the Excel error message is

1702213
11-28-2018, 01:01 PM
Are you using .xls or .xlsx files?

Otherwise, I can't guess why if doesn't save


Comment out the On Error and see what the Excel error message is

Hi, sorry to open an old thread. I also had an issue with .xlsx files, so I switched to .xls... and all it saves is a "Lodging.txt" file in the path location. Any suggestions?

CharlieP
01-09-2019, 08:04 AM
I am using the same formula to create individual workbooks by tab name, but my files use Month, YTD and Full Year tabs, so each person will have a name, name(2) and name(3) tab prior to VBA utilization (of course cannot have redundant tab names in excel). I'm wondering is there an option to combine these tabs into one workbook so ideally each person will have an individual workbook containing Month, YTD and Full Year tabs, i've heard you can pull by the first X characters of a tab name, but even more ideally would be if it could combine like tab names while excluding numbers and special characters. Any insight would be greatly appreciated.


welcome to vbax.

please use code tags when pasting your macros. # button in qucik reply will do it for you.

assuming A1 cells in all worksheets contain the workbook names, try:


Sub Splitbook()

Dim ws As Worksheet

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

For Each ws In ThisWorkbook.Worksheets
ws.Copy
With ActiveWorkbook
.SaveAs Filename:=ThisWorkbook.Path & "\" & ws.Range("A1") & ".xls", FileFormat:=56 '(56 = Excel8 excel file = .xls)
.Close False
End With
Next

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub