Sub SaveShtsAsBook()
‘Select all visible and hide sheet’
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4)
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder
For N = 1 To Sheets.Count
Sheets(N).Activate
SheetName = ActiveSheet.Name
Cells.Copy
Workbooks.Add (xlWBATWorksheet)
With ActiveWorkbook
With .ActiveSheet
.Paste
.Name = SheetName
[A1].Select
End With
'save book in this folder
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xlsx"
.Close SaveChanges:=True
End With
.CutCopyMode = False
Next
End With
Sheet1.Activate
End Sub
I have a workbook, that contains many sheets which have visible and hide ones. I only want to export each visible sheet to individual workbook. this current code above can do the export for all the sheet in the workbook but I have to delete them 1 by 1 after that. Hope that explains my situation.
All you need to add to your code to exclude hidden sheets is a simple If..Then statement to check whether the Worksheet.Visible property is True or False.
If Not yourWorsheet.Visible Then... ... then you skip that worksheet.
The following procedure is a simpler overall approach to what you're trying to accomplish...
Export Visible worksheets to their own workbooks:
The worksheet.Copy method will create a new workbook if neither Before nor After are specified.
Sub saveVisibleSheetsAsXLSM() 'saves all visible sheets as new xlsx files
Const exportPath = "x:\yourDestinationPath\"
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets 'for each worksheet
If ws.Visible Then 'if it's visible:
Debug.Print "Exporting: " & ws.Name
ws.Copy '(if no params specified, COPY creates + activates a new wb)
Set wbNew = Application.ActiveWorkbook 'get new wb object
wbNew.SaveAs exportPath & ws.Name & ".xlsm", 52 'save new wb
wbNew.Close 'close new wb
Set wbNew = Nothing 'cleanup
End If
Next ws
Set ws = Nothing 'clean up
End Sub
Worksheet.Copy Remarks:
If you don't specify either Before or After, Microsoft Excel creates a new workbook that contains the copied sheet object that contains the copied Worksheet object. The newly created workbook holds the Application.ActiveWorkbook Property (Excel) property and contains a single worksheet. The single worksheet retains the Worksheet.Name Property (Excel) and Worksheet.CodeName Property (Excel) properties of the source worksheet. If the copied worksheet held a worksheet code sheet in a VBA project, that is also carried into the new workbook.
An array selection of multiple worksheets can be copied to a new blank Workbook Object (Excel) object in a similar manner.
(Source: Documentation)
Related
I have several sheets I need to copy to a new workbook and then save this workbook.
I'm using the worksheet function to copy which it seems to me like it's the intended purpose of that function.
Here's the MSDN documentation on how to do this task:
Worksheets("Sheet1").Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.copy
This is doing exactly what I want, but it's using the ActiveWorkbook property which might cause some error, if running other codes or just working in parallel of this code running.
I'm looking for a way to manipulate the newly created workbook without having to use the ActiveWorkbook property.
Something along the lines of this:
Dim wb as Workbook
set wb = Worksheets("Sheet1").Copy
wb.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
I've already tried this and it didn't work, but it's just to illustrate the point that it's not using the ActiveWorkbook property to refer to the new workbook.
Thanks in advance
From above comment:
Sub Tester()
With AsNewWorkbook(Sheet1)
Debug.Print .Name
.SaveAs "C:\Temp\blah.xlsx"
End With
End Sub
Function AsNewWorkbook(ws As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet) 'has one sheet...
With wb.Sheets(1) 'stolen from Cristian's answer...
If .Name = ws.Name Then .Name = .Name & "x"
End With
ws.Copy before:=wb.Worksheets(1)
Application.DisplayAlerts = False
wb.Worksheets(2).Delete
Application.DisplayAlerts = True
Set AsNewWorkbook = wb
End Function
#BigBen is right though - typically just using ActiveWorkbook is fine.
An improvement on #TimWilliams response so that you can copy multiple sheets at once:
Sub Test()
Dim sourceBook As Workbook
'
Set sourceBook = ThisWorkbook 'Or ActiveWorkbook or whatever book is needed
With CopySheetsToNewBook(sourceBook.Sheets(Array("Sheet1", "Sheet2")))
.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
End With
sourceBook.Close SaveChanges:=False
End Sub
Public Function CopySheetsToNewBook(ByVal theSheets As Sheets) As Workbook
If theSheets Is Nothing Then
Err.Raise 91, "CopySheetsToNewBook", "Sheets not set"
End If
'
Dim newBook As Workbook
Dim tempSheet As Worksheet
'
Set newBook = Application.Workbooks.Add(xlWBATWorksheet)
Set tempSheet = newBook.Worksheets(1) 'To be deleted later
tempSheet.Name = CDbl(Now) 'Avoid name clashes with the sheets to be copied
'
theSheets.Copy Before:=tempSheet
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True
'
Set CopySheetsToNewBook = newBook
End Function
Copy Worksheet(s) to a New Workbook
Sub NewWorkbook()
' Reference the source workbook.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
swb.Worksheets("Sheet1").Copy ' copy one worksheet to a new workbook
'swb.Worksheets(Array("Sheet1", "Sheet2")).Copy ' copy multiple worksheets
' Reference the destination (new) workbook.
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Debug.Print swb.Name, dwb.Name
End Sub
How do I save a specific sheet to a new workbook using Excel VBA?
I have multiple sheets with names "Sheet1", "Sheet2", "Sheet3" and so on.
I'd like to save all, in individual workbooks, with a single click.
This is returns an alert
Method Save as of object workbook failed
Sub SaveSplitSheet()
Dim ws As Worksheet
Dim wb As Workbook
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "Sheet" & "*" Then
Application.DisplayAlerts = False
ws.Copy
ActiveWorkbook.SaveAs "/Users/Tukiyem/Downloads", FileFormat:=56
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End If
Next
End Sub
Found the answer-> the code below saves multiple sheets that contain name "sheet...." as individual workbooks.
Sub SaveAsInLoop()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "Sheet" & "*" Then
Application.DisplayAlerts = False
ws.Copy
ActiveWorkbook.SaveAs "/Users/Tukiyem/Downloads/" & ws.Name & ".xlsx", FileFormat:=51
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End If
Next
End Sub
I would slightly tweak your code to a For...Next loop rather For Each...Next which will allow the evaluation of which number sheet we are up to in the loop.
This code is an example of how to loop through the worksheets. It will print each sheet name to the Immediate window of the VBE.
Just adapt your SaveAs code within the loop.
Sub SaveAsInLoop()
Dim SheetNumber As Long
For SheetNumber = 1 To ThisWorkbook.Sheets.Count
Debug.Print Sheets("Sheet" & SheetNumber).Name
Next SheetNumber
End Sub
I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....
my code so far:
Sub Newyeartest()
sheetstocopy = "data"
Worksheets(sheetstocopy).Copy
Dim FName As String
Dim FPath As String
FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub
If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?
Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.
The code saves the workbook first, using the path of the current workbook;
Then it starts checking every worksheet, making sure that the name is not "data";
If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;
Sub NewTest()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"
Dim sheetToCopy As String: sheetToCopy = "data"
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> sheetToCopy Then
If ThisWorkbook.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wks.Name).Delete
Application.DisplayAlerts = True
Else
MsgBox "Last worksheet cannot be deleted!"
End If
End If
Next wks
End Sub
This should do the trick:
Option Explicit
Sub Newyeartest()
Dim wb As Workbook
Dim SheetNames As Variant, Key As Variant
Dim FName As String, FPath As String
Application.ScreenUpdating = False
SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy
Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook
'loop through the sheets you previously stored to copy them
For Each Key In SheetNames
ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
Next Key
'delete the first sheet on the new created workbook
Application.DisplayAlerts = False
wb.Sheets(1).Delete
FPath = "C:\Test"
FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You cannot save directly to C:\ so you need to create a folder and the code will work.
I have a workbook with many sheets, both hidden and visible.
I need to copy all but the first sheet to individual folders that are not created
In the original workbook I have :master sheet, sheet 1, sheet 2, sheet 3, etc
every sheet has a title inside the sheet at cell A1
I want to copy all EXCEPT master sheet and the hidden sheets.
I need to save the sheets to individual workbooks
U:\folder
\sheet 1
\sheet 2
\sheet 3
I am so confused. I know i need a loop to go through the sheets, I need a loop to save and set the name variable from the sheet as it runs through the loop, and then it also has to create the folders if needed.
I am so lost in how to mesh that many loops and commands. I can see the overall outline but I am getting lost.
I would really appreciate the help.
I've tried several individual solutions but I have NO idea how to incorporate all of them.
'some of the code i found online I've been trying to merge together to one
'copy only visible sheets
Sub saveVisibleSheetsAsXLSM() 'saves all visible sheets as new xlsx files
Const exportPath = "x:\yourDestinationPath\"
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets 'for each worksheet
If ws.Visible Then 'if it's visible:
Debug.Print "Exporting: " & ws.Name
ws.Copy '(if no params specified, COPY creates + activates a new wb)
Set wbNew = Application.ActiveWorkbook 'get new wb object
wbNew.SaveAs exportPath & ws.Name & ".xlsm", 52 'save new wb
wbNew.Close 'close new wb
Set wbNew = Nothing 'cleanup
End If
Next ws
Set ws = Nothing 'clean up
End Sub
'skip first sheet code
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert your code here.
' The following line shows how to reference a sheet within
' the loop by displaying the worksheet name in a dialog box.
MsgBox ActiveWorkbook.Worksheets(I).Name
Next I
End Sub
Everything was right with your code except the Folder Paths.
Use MkDir to create a Folder and then save the Files in it. Use AND in If condition to skip the Master Sheet. I have amended the code.
Code:
Sub saveVisibleSheetsAsXLSM()
Const exportPath = "x:\yourDestinationPath\" '**Change your Path HERE**
Dim ws As Worksheet, wbNew As Workbook
For Each ws In ThisWorkbook.Sheets
If ws.Visible And Not ws.Name = "master sheet" Then '**Check the spelling of Master Sheet**
Debug.Print "Exporting: " & ws.Name
ws.Copy
Set wbNew = Application.ActiveWorkbook
MkDir exportPath & ws.Name
wbNew.SaveAs exportPath & ws.Name & "\" & ws.Name & ".xlsm", 52
wbNew.Close
Set wbNew = Nothing
End If
Next ws
End Sub
I have created some codes and one of my requirement is to copy certain sheets, modules and buttons to refer those modules to a new workbook.
I am facing two problems:
1) While trying various things I am able to copy worksheets and module. However, the problem is when I copy module buttons to new worksheet, it still refers to the original file and not the new file which has been created.
2) When the button delete command runs it deletes buttons from existing workbook and inserts a new button in existing workbook.
I can understand that somewhere I am not getting back to original file but not able to make out where and how to go to new file to execute the code.
The code for copying file, modules and buttons is as listed below.
Sub Workbook_Open()
Dim filename4 As String:
strFilename4 = "\Work Data " & Format(Now(), "ddmmyy hhmmss")
filename4 = ActiveWorkbook.Path & strFilename4 & ".xlsm"
Dim nm As Name
Dim ws As Worksheet
Sheets(Array("Sheet1", "Sheet2")).Copy
For Each nm In ActiveWorkbook.Names
If InStr(1, nm.RefersTo, "#REF!") > 0 Then
Debug.Print nm.Name & ": deleted"
nm.Delete
End If
Next nm
ActiveWorkbook.SaveAs filename:=filename4, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close
Const MODULE_NAME As String = "DataValidityCheck" ' Name of the module to transfer
Const TEMPFILE As String = "c:\DataValidityCheck.bas" ' temp textfile
Dim WBK As Workbook
Set WBK = Workbooks.Open(filename4)
'Copy Module to New Workbook
On Error Resume Next
Set WBK = Workbooks(filename4)
ThisWorkbook.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
WBK.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
'Delete every shape in the Shapes collection
Dim myshape As Shape
For Each myshape In ActiveSheet.Shapes
myshape.Delete
Next myshape
ThisWorkbook.ActiveSheet.Buttons.Add(2538, 4.5, 71.25, 14.25).Select
With btn
.Caption = "Validate Data" 'change the name of the button accordingly
.OnAction = "msg"
End With
Selection.OnAction = "Workbook_Open"
ActiveWorkbook.Close SaveChanges:=True
End If
Application.CutCopyMode = False
End Sub
Your problem stems from the fact that you are not qualifying your workbooks correctly. Using ThisWorkbook will always signify the workbook running the code. Using ActiveWorkbook will always signify the workbook that is active at that moment in the codes execution. While there are perfectly legitimate times and places to use this, its generally a bad practice to do so, especially ActiveWorkbook (and ActiveSheet for that matter).
I have refactored your code with full comments to illustrate this, as well as cleaned up some other syntax related stuff that was in there.
Sub Workbook_Open()
Const MODULE_NAME As String = "DataValidityCheck" ' Name of the module to transfer
Const TEMPFILE As String = "c:\DataValidityCheck.bas" ' temp textfile
'qualify main workbook
Dim wbkMain As Workbook
Set wbkMain = ThisWorkbook
'export desired module
With wbkMain
.VBProject.VBComponents(MODULE_NAME).Export TEMPFILE
'copy out sheets
.Sheets(Array("Sheet1", "Sheet2")).Copy
End With
'qualify new workbook
Dim WBK As Workbook
Set WBK = ActiveWorkbook 'this is one of only a few times its required to use 'ActiveWorkbook'
'work directly with new workbook
With WBK
'Copy Module to New Workbook
.VBProject.VBComponents.Import TEMPFILE
Kill TEMPFILE
'delete bad names
Dim nm As Name
For Each nm In .Names
If InStr(1, nm.RefersTo, "#REF!") Then nm.Delete
Next
'Delete every shape in the Shapes collection
With .Sheets(1) 'change to 2 if you need sheet 2
Dim myshape As Shape
For Each myshape In .Shapes 'change to 2 if you need sheet 2
myshape.Delete
Next myshape
.Buttons.Add(2538, 4.5, 71.25, 14.25).Select
With Selection 'should really set this to a variable as well, but I didn't feel like looking the right syntax
.Caption = "Validate Data" 'change the name of the button accordingly
.OnAction = "msg" 'Workbook_Open if need be
End With
End With
'finally save the new workbook
Dim filename4 As String, strFilename4 As String
strFilename4 = "\Work Data " & Format(Now(), "ddmmyy hhmmss")
filename4 = ActiveWorkbook.Path & strFilename4 & ".xlsm"
.SaveAs Filename:=filename4, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
.Close True 'don't need since you just saved, but why not
End With
Application.CutCopyMode = False
End Sub