Please can someone tell me how to keep the source format for the files created using the below macro. When I open the new files the colours have all changed compared to the original and I need these to match.
Sub SaveSheets()
' Save sheets as seperate workbooks
' Keyboard Shortcut: Ctrl+Shift+W
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sht As Object 'Could be chart, worksheet, Excel 4.0 macro,etc.
Dim strSavePath As String
On Error GoTo ErrorHandler
Application.ScreenUpdating = False 'Don't show any screen movement
strSavePath = "C:\Users\Joe Bloggs\Documents\Save Sheets\" 'Change this to suit your needs
Set wbSource = ActiveWorkbook
For Each sht In wbSource.Sheets
sht.Copy
Set wbDest = ActiveWorkbook
wbDest.SaveAs (strSavePath & sht.Name)
wbDest.Close 'Remove this if you don't want each book closed after saving.
Next
Application.ScreenUpdating = True
Exit Sub
ErrorHandler: 'Just in case something hideous happens
MsgBox "An error has occurred. Error number=" & Err.Number & ". Error description=" & Err.Description & "."
End Sub
Related
Is there a way to save the active/selected worksheet without having to specify sheets(1)?
The code below is execute via command button and will take the worksheet "Quote" copy to a new workbook, and then prompt to save under the downloads directory.
I'm also trying to get that button to save whichever sheet is selected, it could be Quote or Sheet1, but not both.
Private Sub CommandButton4_Click() ' save worksheet
'Gets the name of the currently visible worksheet
Filename = ActiveSheet.Name
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook - uses the name of the worksheet as the name of the new workbook
'Filename = Range("A1")
'ActiveWorkbook.Save
Dim NameFile As Variant
With Worksheets("Quote")
'NameFile = .Range("A1") & "_" & .Range("B5") & "_" & ".xls"
End With
NameFile = Application.GetSaveAsFilename(InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & NameFile, Filefilter:="Fichier Excel (*.xls), *.xls")
If NameFile = False Then
MsgBox "File not saved"
Else
ActiveWorkbook.SaveAs Filename:=NameFile
End If
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Sub
This Sub creates a new Workbook from a sheet. But you must have a way to call this Sub of every sheet, or a better place is a button in the ribbon witch in it's handler: Call NewBookOfSheet(ActiveSheet).
Public Sub NewBookOfSheet(ws As Worksheet)
Dim nwb As Workbook, curwb As Workbook
If ws Is Nothing Then Exit Sub
Set curwb = ws.Parent
Set nwb = Workbooks.Add
curwb.Activate
ws.Select
ws.Copy Before:=nwb.Sheets(1)
nwb.Activate
Application.Dialogs(xlDialogSaveAs).Show ws.Name
End Sub
Copy the Active Worksheet to a New Workbook
Private Sub CommandButton4_Click() ' save worksheet
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim sws As Worksheet: Set sws = ActiveSheet
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
Dim dwbName: dwbName = Application.GetSaveAsFilename( _
InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & dws.Name, _
FileFilter:="Fichier Excel (*.xls), *.xls")
If dwbName = False Then
MsgBox "File not saved", vbCritical
Else
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dwbName, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
End If
dwb.Close SaveChanges:=False
' Now 'dws' and 'dwb' are invalid but still 'Not Nothing'.
' On the other hand, 'sws' still points to the (initial) source worksheet.
' If you need to reference the source workbook use:
'Dim swb As Workbook: Set swb = sws.Parent
End Sub
I'm trying to automate the copying of 3 Excel worksheets from a master file into any other Excel file via VBA code, but I keep getting an "Error 1004: Copy Method Of Worksheet Class Failed".
Here's my code:
Sub CopyandInsert()
Application.ScreenUpdating = False
Set closedBook = Workbooks.Open("\\filepath\master_file.xlsx")
closedBook.Sheets("Long Sheet Name One").Copy After:=ThisWorkbook.Sheets(1)
closedBook.Sheets("Long Sheet Name Two").Copy After:=ThisWorkbook.Sheets(2)
closedBook.Sheets("Long Sheet Name Three").Copy After:=ThisWorkbook.Sheets(3)
closedBook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
VBA is able to find and open the master file, but keeps breaking at the first copy line.
Any ideas? Thank you!
Copy Sheets Using an Array of Sheet Names
Cons
All sheets have to exist.
At least one sheet has to be visible. Any hidden sheets will stay hidden.
Any very hidden sheets will not be copied.
Option Explicit
Sub CopyandInsert()
Const dFilePath As String = "C:\Test.xlsx"
Dim SheetNames As Variant
SheetNames = Array("Sheet1", "Sheet2", "Sheet3")
Application.ScreenUpdating = False
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
dwb.Sheets(SheetNames).Copy After:=ThisWorkbook.Sheets(1)
dwb.Close SaveChanges:=False
'ThisWorkbook.Sheets(1).Select
'Thisworkbook.Save
Application.ScreenUpdating = True
End Sub
Copy Sheets Using a Loop
Sub CopyandInsert2()
Const dFilePath As String = "C:\Test.xlsx"
Dim SheetNames As Variant
SheetNames = Array("Sheet1", "Sheet2", "Sheet3")
Application.ScreenUpdating = False
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
Dim dsh As Object
For Each dsh In dwb.Sheets(SheetNames)
On Error GoTo ClearWorksheetError
dsh.Copy After:=ThisWorkbook.Sheets(1)
Next dsh
dwb.Close SaveChanges:=False
'ThisWorkbook.Sheets(1).Select
'Thisworkbook.Save
Application.ScreenUpdating = True
Exit Sub
ClearWorksheetError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & Err.Description, _
vbCritical
Resume Next
End Sub
PERSONAL.xlsb
To make it work correctly, you need to select (look at) the file where you want to add the copied sheets, then open the macro-dialog and select the CopyandInsert macro.
Option Explicit
Sub CopyandInsert()
Const dFilePath As String = "C:\Test.xlsx"
Dim SheetNames As Variant
SheetNames = Array("Sheet1", "Sheet2", "Sheet3")
Dim swb As Workbook: Set swb = ActiveWorkbook
Application.ScreenUpdating = False
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
dwb.Sheets(SheetNames).Copy After:=swb.Sheets(1)
dwb.Close SaveChanges:=False
'swb.Sheets(1).Select
'swb.Save
Application.ScreenUpdating = True
End Sub
First I open a SubWorkbook than copy data from worksheet to update MainWorkbook (paste below):
The problem occur when I try to set variable for worksheet from the workbook I just open. It said: "Subscript out of Range".
What happen to it and how I can fix it, or is it wrong direction that I have to go from another way.
Sub Data_Inbound()
Dim mywb As Workbook
Dim FName As String
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Set mywb = ActiveWorkbook
On Error GoTo errHandler:
FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xlsx*", Title:="Please select an Excel file")
Workbooks.Open FileName:=FName
Set wsCopy = Workbooks(FName).Worksheets(Sheet1)
Set wsDest = Workbooks(mywb).Worksheets(Sheet1)
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
wsDest.Activate
errHandler:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Data_Inbound"
Exit Sub
End Sub
I see other guy they have the same question, but they use worksheet name, for me I use a variant variable, but it lead to error:
Other guy:
Set wsCopy = Workbooks("Warranty Template.xlsm").Worksheets("PivotTable")
Copy/Paste From Closed Workbook
The code has run successfully if you see the message. If not, something went wrong, and there is a message in the Immediate window CTRL+G.
The Code
Option Explicit
Sub Data_Inbound()
' Initialize error handling.
Const ProcName As String = "Data_Inbound"
' Do not use error handling while developing the code.
On Error GoTo clearError ' Turn on error trapping.
' Define Destination Workbook.
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Workbook Name.
Dim srcName As String
srcName = Application.GetOpenFilename(filefilter:="Excel Files,*.xlsx*", _
Title:="Please select an Excel file")
' Open Source Workbook (No variable, but it is the active one).
Workbooks.Open Filename:=srcName
' Define Source Worksheet ('wsSource').
Dim wsSource As Worksheet
Set wsSource = ActiveWorkbook.Worksheets("Sheet1") ' Note the double quotes.
' Define Destination Worksheet ('wsDest')
Dim wsDest As Worksheet
Set wsDest = wb.Worksheets("Sheet1") ' Note the double quotes...
' ... and not: Set wsDest = Workbooks(wb).Worksheets("Sheet1") - wrong!
' Define Source Last (Non-Empty) Row ('srcLastRow').
Dim srcLastRow As Long
srcLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
' Define Destination First (Empty (available)) Row ('destFirstRow').
Dim destFirstRow As Long
destFirstRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
' Copy from Source to Destination.
wsSource.Range("A2:A" & srcLastRow).Copy wsDest.Range("A" & destFirstRow)
' Note "A2:A" and not: "A2" - wrong!
' Now you wanna close the Source Workbook, but how?
' You can use the 'Parent' property:
wsSource.Parent.Close False ' False means not to save changes.
' If you closed, wsDest is active again so you don't need:
'wsDest.Activate
' Inform user, so you know the code has finished.
MsgBox "Copied data.", vbInformation, "Success"
ProcExit:
Exit Sub
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Sub
Apologies for any bad coding or ignorance I'm a very basic user of VBA.
I have a WorkbookA that has X number of sheets which can change daily. I cobbled together code which will copy the active sheet from WorkbookA to WorkbookB, define a save directory and name, save, and close WorkbookB.
I want to loop through all sheets in WorkbookA starting from the active sheet to the last sheet. How can i go about doing this?
Public Sub CopySheetToNewWorkbook()
ActiveSheet.Copy
Name = ActiveSheet.Name & ".xls"
Path = "MyPath\"
ActiveWorkbook.SaveAs (Path & Name)
ActiveWorkbook.Close
End Sub
Copy Sheets to Separate Workbooks
Use with caution because files will be overwritten without asking.
Option Explicit
Sub CopySheetToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim i As Long ' Sheets Counter
Dim SavePath As String ' Save Path
Dim SaveFullName As String ' Save Full Name
With ThisWorkbook
Set ws = .ActiveSheet
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator
Application.ScreenUpdating = False
For i = ws.Index To .Sheets.Count
With .Sheets(i)
SaveFullName = SavePath & .Name & ".xls"
.Copy
End With
GoSub SaveAndClose
Next i
Application.ScreenUpdating = True
End With
MsgBox "Copied sheets to new workbooks.", vbInformation, _
"New Workbooks Saved and Closed"
GoTo exitProcedure
' Save and close new workbook.
SaveAndClose:
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SaveFullName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
Return
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Copy Sheets to Single Workbook
I developed this code first assuming (misreading the post) that the ActiveSheet had some kind of date in its name.
Use with caution because files will be overwritten without asking.
Sub CopySheetsToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim SheetsGroup() As String ' Sheets Group Array
Dim SheetsDiff As Long ' Sheets Difference
Dim i As Long ' Sheets Array Elements (Columns) Counter
Dim SavePath As String ' Save Path
Dim SaveName As String ' Save Name
' Copy sheets from this workbook to new workbook.
With ThisWorkbook
' Define First Worksheet, Save Name and Save Path.
Set ws = .ActiveSheet
SaveName = ws.Name & ".xls"
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator & SaveName
' Write sheet names to Sheets Group Array.
ReDim SheetsGroup(.Sheets.Count - ws.Index)
SheetsDiff = .Sheets.Count - ws.Index
For i = 0 To SheetsDiff
SheetsGroup(i) = .Worksheets(i + SheetsDiff - 1).Name
Next i
' Copy sheets from Sheets Group Array to new workbook (ActiveWorkbook).
.Sheets(SheetsGroup).Copy
End With
' Save and close New Workbook.
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' from complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SavePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
MsgBox "Copied sheets to new workbook.", vbInformation, _
"New Workbook Saved and Closed"
GoTo exitProcedure
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Close Workbooks
A few times I had over ten workbooks open while developing the previous code, so I wrote this little time saver.
Use it with caution because workbooks will be closed without saving changes.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Closes all workbooks except this one (ThisWorkbook). '
' Remarks: Be careful because all the changes on those other workbooks '
' will be lost. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub closeWorkbooks()
Dim wb As Workbook
Application.ScreenUpdating = False
For Each wb In Workbooks
If Not wb Is ThisWorkbook Then wb.Close False
Next wb
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
I am working on a Userform that will copy a specific sheet from Workbook A and paste it into Workbook B (essentially archiving that data). The Userform presents the user with a combo-box dropdown to select the sheet name to be copied. I receive a subscript out of range error however when using the sheets.copy command. Here is my code with names modified for ease of reading:
Dim ws as Worksheet
Dim WorkbookA as Workbook
Dim WorkbookB as Workbook
Dim ComboBoxValue as String
Set WorkbookA as ActiveWorkbook
Set WorkbookB as Workbook.Open("C:File Path Here")
With ThisWorkbook
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name = UserForm1.ComboBox1.Text Then
ComboBoxValue = ws.Name
Worksheets(ComboBoxValue).Copy _
After:=Workbooks("Workbook B.xlsm").Sheets(Sheets.Count)
' Run-Time 9 Subscript Out of Range Error occurs on line above ^
ActiveSheet.Name = UserForm1.ComboBoxSelection.Text
WorkbookB.Save
WorkbookB.Close
WorkbookA.Activate
Application.CutCopyMode = False
End If
Next ws
End With
The root of your error is improper refenceing of the workbook. There are a lot of other issues, too.
Unnecassary reference to ThisWorkbook
Unnecassary loop through all worksheets
Unnecassary renaming of copied sheet
Unnecassry / incorrect references to the ActiveWorkbook and ActiveSheet
No Error Handling
Improper indenting
Your code, refactored. This is written as a button click event in the UserForm. Update to suit your needs.
Option Explicit
Const ArchiveFilePath As String = "C:\Path\To\ArchiveBook.xlsx"
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim WorkbookA As Workbook
Dim WorkbookB As Workbook
Dim wsName As String
Application.ScreenUpdating = False
Set WorkbookA = ActiveWorkbook
wsName = UserForm1.ComboBox1.Text
If wsName = vbNullString Then Exit Sub
On Error Resume Next 'Handle possibility that Open fails
Set WorkbookB = Workbooks.Open(ArchiveFilePath)
On Error GoTo 0
If WorkbookB Is Nothing Then
MsgBox "Failed to open " & ArchiveFilePath, vbOKOnly, "Error"
Exit Sub
End If
'Check if specified ws already exists in WorkbookB
Set ws = GetWorksheet(WorkbookB, wsName)
If Not ws Is Nothing Then
' Sheet already exists. What now?
MsgBox "Sheet " & wsName & " already exists in " & WorkbookB.Name & ". What now?", vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
Set ws = GetWorksheet(WorkbookA, wsName)
If ws Is Nothing Then
MsgBox "Sheet " & wsName & " does not exist in " & WorkbookA.Name, vbOKOnly, "Error"
WorkbookB.Close
Exit Sub
End If
ws.Copy After:=WorkbookB.Sheets(WorkbookB.Sheets.Count)
WorkbookB.Save
WorkbookB.Close
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Function GetWorksheet(wb As Workbook, wsName As String) As Worksheet
On Error GoTo EH
Set GetWorksheet = wb.Worksheets(wsName)
EH:
End Function
Change Sheets(Sheets.Count) to Sheets(Workbooks("Workbook B.xlsm").Sheets.Count)
In this context, Sheets(Sheets.Count) is referring to your source workbook object, so you must specify to count the sheets in the other book.