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
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 am trying to export tabs in my excel workbook which are in green color into csv files. Any pointers will be much appreciated.
Export to CSV
Basic
Sub ExportToCSV()
Const DST_PATH As String = "C:\Test"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Application.ScreenUpdating = False
Dim sws As Worksheet
Dim dwb As Workbook
Dim dFilePath As String
For Each sws In wb.Worksheets
If sws.Tab.Color = vbGreen Then
sws.Copy ' creates a new single-worksheet workbook
Set dwb = Workbooks(Workbooks.Count)
dFilePath = DST_PATH & Application.PathSeparator & sws.Name & ".csv"
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSV ' xlCSVUTF8
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
End If
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
I have a workbook with filtered ranges on each sheet. I have tried a couple different methods but when stepping through it only does the first sheet or none at all. This is what I have tried.
dim ws as worksheet
For Each Ws In ThisWorkbook.Worksheets
If Ws.AutoFilterMode Then
Ws.AutoFilter.ShowAllData
End If
Next Ws
this one isn't doing anything at all
this one is less sophisticated and not what I want.
For Each ws In ThisWorkbook.Worksheets
Rows("1:1").Select
Selection.AutoFilter
Next ws
this is only doing the first worksheet and not moving to the next.
this is the full code and it is not returning any errors
Sub Cleanup()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim mergedWb As Workbook
Set mergedWb = Workbooks.Add()
Dim FolderPath As String
Dim Filename As String
Dim Sheet As Worksheet
Dim ws As Worksheet
Application.ScreenUpdating = False
FolderPath = "<folder path>"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
Dim wb As Workbook
Set wb = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
For Each Sheet In wb.Sheets
Sheet.Copy After:=mergedWb.Sheets(1)
Next Sheet
wb.Close
Filename = Dir()
Loop
Sheets(1).Delete
For Each ws In ThisWorkbook.Worksheets
If ws.AutoFilterMode Then
ws.AutoFilter.ShowAllData
End If
Next ws
End Sub
Copy Sheets to New Workbook
Issues
ThisWorkbook is the workbook containing this code. It has nothing to do with the code so far: you're adding a new (destination) workbook (mergedWb) and you're opening (source) files ('wb') whose sheets (Sheet) will be copied. Instead, you should use:
For Each ws In mergedWb.Worksheets
When you use the Sheets collection, you need to keep in mind that it also includes charts. Therefore, you should declare:
Dim Sheet As Object
You need to qualify the first destination (work)sheet to ensure the correct worksheet is deleted:
Application.DisplayAlerts = False ' delete without confirmation
mergedWb.Sheets(1).Delete
Application.DisplayAlerts = True
To turn off the auto filter, you need to use:
dws.AutoFilterMode = False
You can avoid the loop by copying all sheets (that are not very hidden) at once (per workbook):
swb.Sheets.Copy After...
The line swb.Sheets.Copy (no arguments) copies all sheets (that are not very hidden) to a new workbook.
The Code
Option Explicit
Sub Cleanup()
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_FILE_PATTERN As String = "*.xls*"
If Not CreateObject("Scripting.FileSystemObject") _
.FolderExists(SOURCE_FOLDER_PATH) Then
MsgBox "The folder '" & SOURCE_FOLDER_PATH & "' doesn't exist.", _
vbCritical
Exit Sub
End If
Dim sFolderPath As String: sFolderPath = SOURCE_FOLDER_PATH
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & SOURCE_FILE_PATTERN)
If Len(sFileName) = 0 Then
MsgBox "No files found."
Exit Sub
End If
Dim swb As Workbook
Dim dwb As Workbook
Dim sFilePath As String
Dim IsNotFirstSourceWorkbook As Boolean
Application.ScreenUpdating = False
Do While Len(sFileName) > 0
sFilePath = sFolderPath & sFileName
Set swb = Workbooks.Open(Filename:=sFilePath, ReadOnly:=True)
If IsNotFirstSourceWorkbook Then
swb.Sheets.Copy After:=dwb.Sheets(dwb.Sheets.Count)
Else
swb.Sheets.Copy ' creates a new workbook containing the sheets
Set dwb = Workbooks(Workbooks.Count)
IsNotFirstSourceWorkbook = True
End If
swb.Close SaveChanges:=False
sFileName = Dir()
Loop
Dim dws As Worksheet
For Each dws In dwb.Worksheets
If dws.AutoFilterMode Then dws.AutoFilterMode = False
Next dws
' Decide what to do with the new workbook e.g.:
' Application.DisplayAlerts = False ' overwrite without confirmation
' dwb.SaveAs sFolderPath & "CleanUp " & Format(Date, "yyyymmdd")
' Application.DisplayAlerts = True
' dwb.Close SaveChanges:=False ' it has just been saved
Application.ScreenUpdating = True
MsgBox "Cleaned up.", vbInformation
End Sub
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 use the following code to import multiple worksheets from another workbook and do some processing. the Importing time is too long. can any one suggest a more efficient way to import? Should I be looking in to more information in the source files for copy?
Sub SKR_Import()
On Error GoTo errorhandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim Sht As Worksheet
Set wb1 = ActiveWorkbook
Dim fd As FileDialog
Dim filechosen As Integer
Dim filename As String
Dim i As Long
Set fd = Application.FileDialog(msoFileDialogOpen)
fd.AllowMultiSelect = True
fd.Title = "Select Excel workbooks to import all sheets"
filechosen = fd.Show
If filechosen = -1 Then
For i = 1 To fd.SelectedItems.Count
Set wb2 = Workbooks.Open(fd.SelectedItems(i))
For Each Sht In wb2.Sheets
Sht.Activate
ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)
Next Sht
wb2.Close SaveChanges:=False
Next i
End If
wb1.Activate
Application.ScreenUpdating = True
Exit Sub
errorhandler:
msgBox Error, vbCritical, "Error"
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Instead of looping on the sheets of wb2, you can try to copy them at once using the copy method of sheets (with an s):
Set wb2 = Workbooks.Open(fd.SelectedItems(i))
' For Each Sht In wb2.Sheets
' Sht.Activate
' ActiveSheet.Copy after:=wb1.Sheets(wb1.Sheets.Count)
' Next Sht
wb2.Sheets.Copy after:=wb1.Sheets(wb1.Sheets.Count)
wb2.Close SaveChanges:=False
This will also get rid of the Activate statement, which wasn't necessary but only wasted some time.
I dont seem to find other ways to accelerate further your code.