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?
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
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
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
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.
Assuming all your macros are in modules, maybe this link will help. After copying the workbook, just iterate over each module and delete it
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
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)
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
Try this instead.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Copy
Next
Source: Stackoverflow.com