VBA to copy a worksheet to a new workbook using same format for .xls files

[WStockel]

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.

 

[WStockel]

Worked perfect. Thanks. Now to figure out how to copy two more sheets to it.

 

[WStockel]

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

Thanks. It works great. I tried to modify it to copy two more sheets. My code is below. problem is it wants to copy to the first sheet instead of making a new sheet.

Sub EMAIL_Click() ' creates a new workbook with no formulas or macros to email
Dim oSht As Worksheet 'original workbook
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 ' creat new workbook

With Application
.ScreenUpdating = False
ThisWorkbook.Worksheets("Results").Copy ' first sheet to copy
Set oSht = ActiveSheet
oSht.Cells.Copy
oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Worksheets("Reports").Copy ' second sheet to copy
Set oSht = ActiveSheet
oSht.Cells.Copy
oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues

''''''''''''''''''''''''''''''''''''''''''''''''''''''
ThisWorkbook.Worksheets("Race Results").Copy ' 3rd sheet to copy
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

 

[GWteB]

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.

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 (between 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

 

[WStockel]

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 (between 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:
oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal
Error message is "There is already data here. Do you want to replace it?"
If I answer YES, I get Run-time error 438. Object doesn't support this property or method.
If I answer NO, I get run-time error 1004. Pastespecial method of range failed.

 

[GWteB]

The "error" message isn't an error, it's a warning, but should not pop up, since we have created a new workbook. I tested the code on populated sheets with dummy data and formulas (with enabled alerts) and it works for me without any alert / warning / run-time error.
What's the content of the sFullName string variable at the point the VBE is complaining?

 

[GWteB]

OOPS my bad, please do change this
oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal

into this

       oWb.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal

 

[WStockel]

OOPS my bad, please do change this
oWb.Parent.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal

into this

       oWb.SaveAs Filename:=sFullName, FileFormat:=xlWorkbookNormal

Thanks so much. It works great now. I still get the warning "There is already data here. Do you want to replace it?", but when I answer yes it finishes perfect. Thanks again for all the help.

 

[GWteB]

You're welcome and thanks for letting me know.

I still get the warning "There is already data here. Do you want to replace it?", but when I answer yes it finishes perfect.

Could be a difference between Excel 2013 and 365, I don't know. You might try adding those two lines.

Application.DisplayAlerts = False    ' <<<<<<<<<<<
oSht.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Application.DisplayAlerts = True     ' <<<<<<<<<<<

 

[WStockel]

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.

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.

 

[GWteB]

Glad to help.