Copying multiple sheets and renaming the worksheet

Question

I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....

my code so far:

Sub Newyeartest()

sheetstocopy = "data"
Worksheets(sheetstocopy).Copy

Dim FName As String
Dim FPath As String

FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub

If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?

Answer 1

Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.

• The code saves the workbook first, using the path of the current workbook;
• Then it starts checking every worksheet, making sure that the name is not "data";
• If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
• The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
• If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;

---

Sub NewTest()

    ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"

    Dim sheetToCopy As String: sheetToCopy = "data"
    Dim wks As Worksheet
    For Each wks In ThisWorkbook.Worksheets
        If wks.Name <> sheetToCopy Then
            If ThisWorkbook.Worksheets.Count > 1 Then
                Application.DisplayAlerts = False
                ThisWorkbook.Worksheets(wks.Name).Delete
                Application.DisplayAlerts = True
            Else
                MsgBox "Last worksheet cannot be deleted!"
            End If
        End If
    Next wks

End Sub

Answer 2

This should do the trick:

Option Explicit
Sub Newyeartest()

    Dim wb As Workbook
    Dim SheetNames As Variant, Key As Variant
    Dim FName As String, FPath As String

    Application.ScreenUpdating = False


    SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy

    Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook

    'loop through the sheets you previously stored to copy them
    For Each Key In SheetNames
        ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
    Next Key

    'delete the first sheet on the new created workbook
    Application.DisplayAlerts = False
    wb.Sheets(1).Delete

    FPath = "C:\Test"
    FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
    wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

You cannot save directly to C:\ so you need to create a folder and the code will work.