Save as a sheet into multiple workbooks based on list

Hansulet

Board Regular
Joined
Jan 24, 2013
Messages
115
Hi,

I need to save as a sheet into multiple workbooks based on a list (This list is Column F). These workbooks must to be renamed based on same list.

For example, in present I have the following list in Column F:

AB
BC
AG
BC
SV
AG

So, I need to save as this sheet into 4 workbooks (AB, AG, BC and SV)


Could you help me?
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
Hi,

I need to save as a sheet into multiple workbooks based on a list (This list is Column F). These workbooks must to be renamed based on same list.

For example, in present I have the following list in Column F:

AB
BC
AG
BC
SV
AG

So, I need to save as this sheet into 4 workbooks (AB, AG, BC and SV)


Could you help me?
Hi Hansulet,

Try out the following in a COPY of your workbook. Remember to change the bold red C:\TESTFolder part to your desired save location:

Rich (BB code):
Sub SaveSpecificSheet()
' Defines variables
Dim ws As Worksheet, wsSheet As Worksheet, wsName As String, fPath As String, Cell As Range, cRange As Range
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Disables alerts to prevent popups
Application.DisplayAlerts = False
' Defines the output filepath
fPath = "C:\TestFolder"
' On error continue
On Error Resume Next
' Set the desired sheet name to save individually as the value entered in text box
wsName = (InputBox("Enter sheet name"))
' Set wsSheet as the specified sheet name
Set wsSheet = Sheets(wsName)
' On error exit
On Error GoTo 0
    ' If the specified sheet exists then...
    If Not wsSheet Is Nothing Then
        ' Set LastRow as the last row of column F
        LastRow = Sheets(wsName).Cells(Rows.Count, "F").End(xlUp).Row
            ' Set the check range as F1 to the last row of F
            Set cRange = Sheets(wsName).Range("F1:F" & LastRow)
                ' For each cell in the check range
                For Each Cell In cRange
                    With ThisWorkbook
                            Dim wb As Workbook
                            ' Create a new workbook
                            Set wb = Application.Workbooks.Add
                            ' Delete Sheets 2 and 3 of the new workbook
                            wb.Sheets(Array(2, 3)).Delete
                            ' Copy the specified sheet of the source workbook and put it in front of Sheet1 of the new workbook
                            ThisWorkbook.Sheets(wsName).Copy Before:=wb.Sheets(1)
                            ' Delete the last blank sheet from the new workbook
                            wb.Sheets(2).Delete
                            ' Save the new workbook to the specified filepath named the corresponding cell value
                            wb.SaveAs Filename:=fPath & "\" & Cell.Value & ".xlsx"
                            ' Close the new workbook
                            wb.Close
                    End With
                ' Check next cell in check range
                Next Cell
            ' Display a message that the specified sheet has been saved to individual workbooks
            MsgBox wsName & " saved as individual workbooks based on column F to " & fPath
    ' Else if the specified sheet does not exist or you cancel the input box then...
    Else
        ' Display an error that the specified sheet does not exist
        MsgBox "Specified sheet does not exist"
    End If
' Re-enables screen updating
Application.ScreenUpdating = True
' Re-enables alerts
Application.DisplayAlerts = True
End Sub
 

Hansulet

Board Regular
Joined
Jan 24, 2013
Messages
115
Sorry for the delaying. Was my laptop broken. I run the above code but it generated an error, which is marked with red. Can you help me?


Sub SaveSpecificSheet()
' Defines variables
Dim ws As Worksheet, wsSheet As Worksheet, wsName As String, fPath As String, Cell As Range, cRange As Range
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Disables alerts to prevent popups
Application.DisplayAlerts = False
' Defines the output filepath
fPath = "D:\Documente\TRANSFERATI"
' On error continue
On Error Resume Next
' Set the desired sheet name to save individually as the value entered in text box
wsName = (InputBox("Enter sheet name"))
' Set wsSheet as the specified sheet name
Set wsSheet = Sheets(wsName)
' On error exit
On Error GoTo 0
' If the specified sheet exists then...
If Not wsSheet Is Nothing Then
' Set LastRow as the last row of column F
Lastrow = Sheets(wsName).Cells(Rows.Count, "F").End(xlUp).Row
' Set the check range as F1 to the last row of F
Set cRange = Sheets(wsName).Range("F1:F" & Lastrow)
' For each cell in the check range
For Each Cell In cRange
With ThisWorkbook
Dim wb As Workbook
' Create a new workbook
Set wb = Application.Workbooks.Add
' Delete Sheets 2 and 3 of the new workbook
wb.Sheets(Array(2, 3)).Delete '------------->>>>>>>HERE IS BLOCKING
' Copy the specified sheet of the source workbook and put it in front of Sheet1 of the new workbook
ThisWorkbook.Sheets(wsName).Copy Before:=wb.Sheets(1)
' Delete the last blank sheet from the new workbook
wb.Sheets(2).Delete
' Save the new workbook to the specified filepath named the corresponding cell value
wb.SaveAs Filename:=fPath & "\" & Cell.Value & ".xlsx"
' Close the new workbook
wb.Close
End With
' Check next cell in check range
Next Cell
' Display a message that the specified sheet has been saved to individual workbooks
MsgBox wsName & " saved as individual workbooks based on column F to " & fPath
' Else if the specified sheet does not exist or you cancel the input box then...
Else
' Display an error that the specified sheet does not exist
MsgBox "Specified sheet does not exist"
End If
' Re-enables screen updating
Application.ScreenUpdating = True
' Re-enables alerts
Application.DisplayAlerts = True
End Sub
 

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
Sorry for the delaying. Was my laptop broken. I run the above code but it generated an error, which is marked with red. Can you help me?

Rich (BB code):
Rich (BB code):
Rich (BB code):
Sub SaveSpecificSheet()
' Defines variables
Dim ws As Worksheet, wsSheet As Worksheet, wsName As String, fPath As String, Cell As Range, cRange As Range
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Disables alerts to prevent popups
Application.DisplayAlerts = False
' Defines the output filepath
fPath = "D:\Documente\TRANSFERATI"
' On error continue
On Error Resume Next
' Set the desired sheet name to save individually as the value entered in text box
wsName = (InputBox("Enter sheet name"))
' Set wsSheet as the specified sheet name
Set wsSheet = Sheets(wsName)
' On error exit
On Error GoTo 0
    ' If the specified sheet exists then...
    If Not wsSheet Is Nothing Then
        ' Set LastRow as the last row of column F
        Lastrow = Sheets(wsName).Cells(Rows.Count, "F").End(xlUp).Row
            ' Set the check range as F1 to the last row of F
            Set cRange = Sheets(wsName).Range("F1:F" & Lastrow)
                ' For each cell in the check range
                For Each Cell In cRange
                    With ThisWorkbook
                            Dim wb As Workbook
                            ' Create a new workbook
                            Set wb = Application.Workbooks.Add
                            ' Delete Sheets 2 and 3 of the new workbook
                            wb.Sheets(Array(2, 3)).Delete '------------->>>>>>>HERE IS BLOCKING
                            ' Copy the specified sheet of the source workbook and put it in front of Sheet1 of the new workbook
                            ThisWorkbook.Sheets(wsName).Copy Before:=wb.Sheets(1)
                            ' Delete the last blank sheet from the new workbook
                            wb.Sheets(2).Delete
                            ' Save the new workbook to the specified filepath named the corresponding cell value
                            wb.SaveAs Filename:=fPath & "\" & Cell.Value & ".xlsx"
                            ' Close the new workbook
                            wb.Close
                    End With
                ' Check next cell in check range
                Next Cell
            ' Display a message that the specified sheet has been saved to individual workbooks
            MsgBox wsName & " saved as individual workbooks based on column F to " & fPath
    ' Else if the specified sheet does not exist or you cancel the input box then...
    Else
        ' Display an error that the specified sheet does not exist
        MsgBox "Specified sheet does not exist"
    End If
' Re-enables screen updating
Application.ScreenUpdating = True
' Re-enables alerts
Application.DisplayAlerts = True
End Sub
Hmm, by default Excel should generate 3 blank sheets when a new workbook is created. Are you able to confirm that your new workbooks follow this standard pattern?

Also, when it errors what is the actual error message you see before you press the Debug button?
 

Hansulet

Board Regular
Joined
Jan 24, 2013
Messages
115

ADVERTISEMENT

The message is:

RUN-TIME ERROR '9':
SUBSCRIPT OUT OF RANGE

And in this case Excel generate only one sheet (sheet1) in a new workbook (book1)
 

Fishboy

Well-known Member
Joined
Feb 13, 2015
Messages
4,261
The message is:

RUN-TIME ERROR '9':
SUBSCRIPT OUT OF RANGE

And in this case Excel generate only one sheet (sheet1) in a new workbook (book1)
OK, the Out Of Range error is because we are trying to delete sheets 2 and 3 but they don't exist. If you new workbooks only have a single sheet by default then you can simply remove the entire offending line of code. To test this out just put a ' at the start of that line and then try the code again.
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,963
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi, Hansulet
I noticed that the list in column F is not unique.
So try this:
The sheet where you have the list must be the active sheet

Code:
Sub copyWB2()
Dim ws1 As Worksheet
Dim wbNew As Workbook
Dim d
Dim x
Dim r As Range
Dim fld  As String
Application.ScreenUpdating = False

Set ws1 = ActiveSheet

fld = "D:\atry\ccc\"  'change this path to suit

Set d = CreateObject("scripting.dictionary")
d.compareMode = vbTextCompare

For Each r In Range("F1:F" & Range("F" & Rows.count).End(xlUp).row)
If r.Value <> vbNullString Then
    If Not d.Exists(r.Value) Then
    d(r.Value) = 1
    End If
End If
Next

For Each x In d
Set wbNew = Workbooks.Add
ws1.Copy Before:=wbNew.sheets(1)
wbNew.SaveAs Filename:=fld & x & ".xlsx"
wbNew.Close True
Next
Application.ScreenUpdating = True
End Sub
 

Hansulet

Board Regular
Joined
Jan 24, 2013
Messages
115
I corrected the excel option for 3 sheets in a new workbook, but now, the code is blocking with another error:

Sub SaveSpecificSheet()
' Defines variables
Dim ws As Worksheet, wsSheet As Worksheet, wsName As String, fPath As String, Cell As Range, cRange As Range
' Disables screen updating to reduce flicker
Application.ScreenUpdating = False
' Disables alerts to prevent popups
Application.DisplayAlerts = False
' Defines the output filepath
fPath = "D:\Documente\TRANSFERATI"
' On error continue
On Error Resume Next
' Set the desired sheet name to save individually as the value entered in text box
wsName = (InputBox("Enter sheet name"))
' Set wsSheet as the specified sheet name
Set wsSheet = Sheets(wsName)
' On error exit
On Error GoTo 0
' If the specified sheet exists then...
If Not wsSheet Is Nothing Then
' Set LastRow as the last row of column F
Lastrow = Sheets(wsName).Cells(Rows.Count, "F").End(xlUp).Row
' Set the check range as F1 to the last row of F
Set cRange = Sheets(wsName).Range("F1:F" & Lastrow)
' For each cell in the check range
For Each Cell In cRange
With ThisWorkbook
Dim wb As Workbook
' Create a new workbook
Set wb = Application.Workbooks.Add
' Delete Sheets 2 and 3 of the new workbook
wb.Sheets(Array(2, 3)).Delete
' Copy the specified sheet of the source workbook and put it in front of Sheet1 of the new workbook
ThisWorkbook.Sheets(wsName).Copy Before:=wb.Sheets(1)
' Delete the last blank sheet from the new workbook
wb.Sheets(2).Delete
' Save the new workbook to the specified filepath named the corresponding cell value
wb.SaveAs Filename:=fPath & "\" & Cell.Value & ".xlsx" '------------->>>>>>>HERE IS BLOCKING
' Close the new workbook
wb.Close
End With
' Check next cell in check range
Next Cell
' Display a message that the specified sheet has been saved to individual workbooks
MsgBox wsName & " saved as individual workbooks based on column F to " & fPath
' Else if the specified sheet does not exist or you cancel the input box then...
Else
' Display an error that the specified sheet does not exist
MsgBox "Specified sheet does not exist"
End If
' Re-enables screen updating
Application.ScreenUpdating = True
' Re-enables alerts
Application.DisplayAlerts = True
End Sub
 

Akuini

Well-known Member
Joined
Feb 1, 2016
Messages
2,963
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for replying.
You can mark this thread as solved.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,803
Messages
5,638,448
Members
417,025
Latest member
MusterDuster

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
Top