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
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
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
I am currently using following code to save an Excel workbook. Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Sub Button3_Click()
' Yes
' Code to save consumer wise mirs on the desktop
Dim Path As String
Dim filename As String
On Error GoTo Err_Clear
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Err_Clear:
If Err <> 0 Then
MkDir CreateObject("wscript.shell").specialfolders("desktop") & "\rohailnisar"
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
End If
End Sub
Export a Worksheet
This saves a copy of a worksheet as the only sheet in a new workbook in the same folder. Before saving, it converts formulas to values. It is saved in the .xlsx format 'removing' any code.
If the code is in the open (initial) workbook, then replace ActiveWorkbook with ThisWorkbook.
Option Explicit
Sub SaveWorksheet()
On Error GoTo ClearError
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("Reconciliation")
Dim FolderPath As String: FolderPath = swb.Path & Application.PathSeparator
Dim BaseName As String: BaseName = sws.Range("E1").Value
Dim FilePath As String: FilePath = FolderPath & BaseName & ".xlsx"
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
dwb.Worksheets(1).UsedRange.Value = dwb.Worksheets(1).UsedRange.Value
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'dwb.Close
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Code
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbThat As Workbook
Dim wsThat As Worksheet
'~~> Change this to the workbook which has the Reconciliation sheet
Set wbThis = ThisWorkbook
Set wsThis = wbThis.Sheets("Reconciliation")
'~~> This will create a new workbook with only Reconciliation
wsThis.Copy
'~~> Get that object. It will be last in the queue
Set wbThat = Workbooks(Workbooks.Count)
Set wsThat = wbThat.Sheets("Reconciliation")
'~~> Convert to values
wsThat.UsedRange.Value = wsThat.UsedRange.Value
'~~> Save that workbook
wbThat.SaveAs Filename:=Path & Filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
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.
I am trying to do a copy and paste of data in between workbooks and worksheets. I have the following codes but it seems to be taking up much time. I was wondering if there is any simpler way in copying?
Sub Test1()
Dim wb As Workbook, x As String, y As String, wb1 As Workbook
For Each wb In Application.Workbooks
If wb.Name <> ThisWorkbook.Name Then x = wb.Name
Next wb
Workbooks(x).Activate
Sheets("Sheet1").Range("A:E").Copy
ActiveWindow.WindowState = xlMinimized
Sheets("Sheet1").Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll
Sheets("Sheet1").Range("A1").Select
Workbooks(x).Activate
ActiveWindow.WindowState = xlNormal
Sheets("Sheet1").Range("F:F").Copy
ActiveWindow.WindowState = xlMinimized
Sheets("Sheet1").Range("G:G").Select
Selection.PasteSpecial Paste:=xlPasteAll
Workbooks(x).Activate
ActiveWindow.WindowState = xlNormal
End Sub
Some headsup:- Use
Sub Test1()
Application.Screenupdating = False
'yourcode
Application.Screenupdating = True
End Sub
in your code to execute it faster
for copy paste a short verion that can be used is
Sheets("Sheet1").Range("F:F").Copy Sheets("Sheet1").Range("G:G")
Instead of activating certain books try pasting directly to the destination as mentioned in the above code.
you can remove "ActiveWindow.WindowState = xlMinimized"
EDIT:- as per added comments
dim wb1 as workbook
dim wb2 as workbook
set wb1 = ("Filename.xlsx")
set wb2 = ("filename.xlsx")
wb1.sheetname.range("A1").copy wb2.sheetname.range("A1")
you can further decalre your sheetname as well
dim ws as worksheet
set ws = worksheets("Sheetname")
Edit as per second comment (add variable to newly opened workbook)
Dim path as variant
dim wsb as workbook
path = \\C:your path ' not the sheet name
Set wsb = Workbooks.Open(filename:=myfolder & "\" & "filename".xlsm")
'your codes
I got some idea from JMAX and found a way which is as follows:
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet1").Range("A:B").Copy
wb.Worksheets("Sheet1").Activate
wb.Worksheets("Sheet1").Range("A1").PasteSpecial Paste:=xlPasteAll
End Sub