How to copy sheets to another workbook using vba? - excel

Question

So, what I want to do, generally, is make a copy of a workbook. However, the source workbook is running my macros, and I want it to make an identical copy of itself, but without the macros. I feel like there should be a simple way to do this with VBA, but have yet to find it. I am considering copying the sheets one by one to the new workbook, which I will create. How would I do this? Is there a better way?

Answer 1

I would like to slightly rewrite keytarhero's response:
Sub CopyWorkbook()
Dim sh as Worksheet, wb as workbook
Set wb = workbooks("Target workbook")
For Each sh in workbooks("source workbook").Worksheets
sh.Copy After:=wb.Sheets(wb.sheets.count)
Next sh
End Sub
Edit: You can also build an array of sheet names and copy that at once.
Workbooks("source workbook").Worksheets(Array("sheet1","sheet2")).Copy _
After:=wb.Sheets(wb.sheets.count)
Note: copying a sheet from an XLS? to an XLS will result into an error. The opposite works fine (XLS to XLSX)

Answer 2

Someone over at Ozgrid answered a similar question. Basically, you just copy each sheet one at a time from Workbook1 to Workbook2.
Sub CopyWorkbook()
Dim currentSheet as Worksheet
Dim sheetIndex as Integer
sheetIndex = 1
For Each currentSheet in Worksheets
Windows("SOURCE WORKBOOK").Activate
currentSheet.Select
currentSheet.Copy Before:=Workbooks("TARGET WORKBOOK").Sheets(sheetIndex)
sheetIndex = sheetIndex + 1
Next currentSheet
End Sub
Disclaimer: I haven't tried this code out and instead just adopted the linked example to your problem. If nothing else, it should lead you towards your intended solution.

Answer 3

You could saveAs xlsx. Then you will loose the macros and generate a new workbook with a little less work.
ThisWorkbook.saveas Filename:=NewFileNameWithPath, Format:=xlOpenXMLWorkbook

Answer 4

I was able to copy all the sheets in a workbook that had a vba app running, to a new workbook w/o the app macros, with:
ActiveWorkbook.Sheets.Copy

Answer 5

Assuming all your macros are in modules, maybe this link will help. After copying the workbook, just iterate over each module and delete it

Answer 6

Try this instead.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
Next

Answer 7

You can simply write
Worksheets.Copy
in lieu of running a cycle.
By default the worksheet collection is reproduced in a new workbook.
It is proven to function in 2010 version of XL.

Answer 8

Workbooks.Open Filename:="Path(Ex: C:\Reports\ClientWiseReport.xls)"ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet

Answer 9

Here is one you might like it uses the Windows FileDialog(msoFileDialogFilePicker) to browse to a closed workbook on your desktop, then copies all of the worksheets to your open workbook:
Sub CopyWorkBookFullv2()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim x As Integer
Dim closedBook As Workbook
Dim cell As Range
Dim numSheets As Integer
Dim LString As String
Dim LArray() As String
Dim dashpos As Long
Dim FileName As String
numSheets = 0
For Each ws In Application.ActiveWorkbook.Worksheets
If ws.Name <> "Sheet1" Then
Sheets.Add.Name = "Sheet1"
End If
Next
Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
Dim MyString As String
fileExplorer.AllowMultiSelect = False
With fileExplorer
If .Show = -1 Then 'Any file is selected
MyString = .SelectedItems.Item(1)
Else ' else dialog is cancelled
MsgBox "You have cancelled the dialogue"
[filePath] = "" ' when cancelled set blank as file path.
End If
End With
LString = Range("A1").Value
dashpos = InStr(1, LString, "\") + 1
LArray = Split(LString, "\")
'MsgBox LArray(dashpos - 1)
FileName = LArray(dashpos)
strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "\" & FileName
Set closedBook = Workbooks.Open(strFileName)
closedBook.Application.ScreenUpdating = False
numSheets = closedBook.Sheets.Count
For x = 1 To numSheets
closedBook.Sheets(x).Copy After:=ThisWorkbook.Sheets(1)
x = x + 1
If x = numSheets Then
GoTo 1000
End If
Next
1000
closedBook.Application.ScreenUpdating = True
closedBook.Close
Application.ScreenUpdating = True
End Sub

Answer 10

try this one
Sub Get_Data_From_File()
'Note: In the Regional Project that's coming up we learn how to import data from multiple Excel workbooks
' Also see BONUS sub procedure below (Bonus_Get_Data_From_File_InputBox()) that expands on this by inlcuding an input box
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Application.ScreenUpdating = False
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
'copy data from A1 to E20 from first sheet
OpenBook.Sheets(1).Range("A1:E20").Copy
ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues
OpenBook.Close False
End If
Application.ScreenUpdating = True
End Sub
or this one:
Get_Data_From_File_InputBox()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim ShName As String
Dim Sh As Worksheet
On Error GoTo Handle:
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
ShName = Application.InputBox("Enter the sheet name to copy", "Enter the sheet name to copy")
For Each Sh In OpenBook.Worksheets
If UCase(Sh.Name) Like "*" & UCase(ShName) & "*" Then
ShName = Sh.Name
End If
Next Sh
'copy data from the specified sheet to this workbook - updae range as you see fit
OpenBook.Sheets(ShName).Range("A1:CF1100").Copy
ThisWorkbook.ActiveSheet.Range("A10").PasteSpecial xlPasteValues
OpenBook.Close False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
Handle:
If Err.Number = 9 Then
MsgBox "The sheet name does not exist. Please check spelling"
Else
MsgBox "An error has occurred."
End If
OpenBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
both work as