I need a VBA code to copy a worksheet to a new workbook using the same format. I only want to copy values and not formulas. Since this file will be emailed to a number of members I need it done in .xls format.
VBA Code:Public Sub CopySheet() Dim oSht As Worksheet Dim sFullName As String sFullName = ThisWorkbook.Path & "\NewBook.xls" ' <<<<< With Application .ScreenUpdating = False ThisWorkbook.Worksheets("Sheet1").Copy ' <<< change accordingly Set oSht = ActiveSheet oSht.Cells.Copy oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues .CutCopyMode = False oSht.Cells(1, 1).Select oSht.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal .ScreenUpdating = True End With End Sub
With Application ... End With
) and left some comments for better understanding.Sub EMAIL_Click() ' creates a new workbook with no formulas or macros to email
Dim oWb As Workbook
Dim oSht As Worksheet 'original workbook (<<< Not realy / not anymore)
Dim sFullName As String ' worksheet
''''''''''''''''''''
Dim nShtName As String
Dim rDate As String
Dim col As Integer
''''''''''''''''''''''
col = Worksheets("Menu").Cells(6, 4).Value + 1 'column to read track name and event date
rDate = Worksheets("Race Results").Cells(2, col).Value
rDate = Replace(rDate, "/", "-")
' get last race results track and date to use as new sheet name
If Worksheets("Race Results").Cells(1, col).Value <> "" And Worksheets("Race Results").Cells(2, col).Value <> "" Then
nShtName = "\" & Worksheets("Race Results").Cells(1, col).Value & " " & rDate
'''nShtName = nShtName & " " & Worksheets("Race Results").Cells(2, col).Value
Else
''''''''''' add code if track and date cells are blank
End If
sFullName = ThisWorkbook.Path & nShtName ' create new workbook name
With Application
.ScreenUpdating = False
' create new workbook with a copy of the desired sheets
ThisWorkbook.Worksheets(Array("Results", "Reports", "Race Results")).Copy ' <<<< sheets to copy
' get a proper reference to the newly created workbook
Set oWb = ActiveSheet.Parent
' iterate through all sheets of the newly created workbook
For Each oSht In oWb.Worksheets
oSht.Cells.Copy
oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
' next two lines are not strictly necessary;
' they ensure the current selection is canceled so leaving a tidy worksheet on screen
oSht.Select
oSht.Cells(1, 1).Select
Next
.CutCopyMode = False
oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal
.ScreenUpdating = True
End With
End Sub
It creates a new workbook with the 3 sheets copied just as I needed but then I get a error msg at this line of code:First of all, a small request. Would you be so kind to use code tags next time. This makes it easier for forum members to read and / or copy your code for testing.
View attachment 15180
My post #10 code creates a blank workbook and places a copy (without formulas) of the desired worksheet in it, as requested. Indeed, the code does not take the presence of multiple worksheets into account. Do I understand correctly that you want all worksheets in the source workbook (or just a selection of those) to be copied together in the same workbook? If so, try the code below. I only amended the copy part (betweenWith Application ... End With
) and left some comments for better understanding.
VBA Code:Sub EMAIL_Click() ' creates a new workbook with no formulas or macros to email Dim oWb As Workbook Dim oSht As Worksheet 'original workbook (<<< Not realy / not anymore) Dim sFullName As String ' worksheet '''''''''''''''''''' Dim nShtName As String Dim rDate As String Dim col As Integer '''''''''''''''''''''' col = Worksheets("Menu").Cells(6, 4).Value + 1 'column to read track name and event date rDate = Worksheets("Race Results").Cells(2, col).Value rDate = Replace(rDate, "/", "-") ' get last race results track and date to use as new sheet name If Worksheets("Race Results").Cells(1, col).Value <> "" And Worksheets("Race Results").Cells(2, col).Value <> "" Then nShtName = "\" & Worksheets("Race Results").Cells(1, col).Value & " " & rDate '''nShtName = nShtName & " " & Worksheets("Race Results").Cells(2, col).Value Else ''''''''''' add code if track and date cells are blank End If sFullName = ThisWorkbook.Path & nShtName ' create new workbook name With Application .ScreenUpdating = False ' create new workbook with a copy of the desired sheets ThisWorkbook.Worksheets(Array("Results", "Reports", "Race Results")).Copy ' <<<< sheets to copy ' get a proper reference to the newly created workbook Set oWb = ActiveSheet.Parent ' iterate through all sheets of the newly created workbook For Each oSht In oWb.Worksheets oSht.Cells.Copy oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues ' next two lines are not strictly necessary; ' they ensure the current selection is canceled so leaving a tidy worksheet on screen oSht.Select oSht.Cells(1, 1).Select Next .CutCopyMode = False oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal .ScreenUpdating = True End With End Sub
OOPS my bad, please do change this
oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal
into this
VBA Code:oWb.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal
Could be a difference between Excel 2013 and 365, I don't know. You might try adding those two lines.I still get the warning "There is already data here. Do you want to replace it?", but when I answer yes it finishes perfect.
Application.DisplayAlerts = False ' <<<<<<<<<<<
oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True ' <<<<<<<<<<<
That fixed it. Thank you so much for all the help on this.You're welcome and thanks for letting me know.
Could be a difference between Excel 2013 and 365, I don't know. You might try adding those two lines.
VBA Code:Application.DisplayAlerts = False ' <<<<<<<<<<< oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues Application.DisplayAlerts = True ' <<<<<<<<<<<