Save as a sheet into multiple workbooks based on list

H

Hansulet

Board Regular
Joined
Jan 24, 2013
Messages
164
Office Version
  1. 2021
Platform
  1. Windows
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

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Sort by date Sort by votes
Hansulet said:
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?
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
Hansulet said:
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
Click to expand...
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?
 
Upvote 0
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)
 
Upvote 0
Hansulet said:
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)
Click to expand...
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.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
You're welcome & thanks for replying.
You can mark this thread as solved.
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Macro to consolidate multiple worksheets into Master based on cell data?
Replies
1
Views
254
bobaol
B
M
  • Question
VBA help required in creating multiple workbooks from one workbook.
Replies
5
Views
269
jolivanes
jolivanes
H
  • Solved
Transpose data.
Replies
4
Views
99
harzer
H
K
  • Question
Help with VB Code to copy workbook
Replies
0
Views
130
kizzie37
K
H
  • Solved
Search for topics based on their groups.
Replies
7
Views
132
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,214,599
Messages
6,120,453
Members
448,967
Latest member
grijken

Share this page

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
Back
Top