Creating a backup copy of Active Sheet using Excel vba

Question

I need to create a backup copy of active Sheet - into a new workbook. So that the new workbook would be created with only Active Sheet in it (no macro, no vba)

I need it to be happening on "After Opening" my Worksheet event

Doing the following:

     Private Sub Workbook_Open()
     
     ActiveWorkbook.SaveCopyAs "E:\Projects\FolderName\FileName.xlsm"
                         
     End Sub

It copies the entire Workbook, with all the vba code and macro in it, not what I need.

Is there a way to only copy the Active Sheet?

Ideally, I would wanted to have cell reference (I store the file path in a different sheet, in a separated cell named "BackupPath").

Is "BackupPath" a named range? If you do not need macro, you should save the workbook as xlsx. Does your named range contain the extension, also? — FaneDuru
@FaneDuru Is "BackupPath" a named range? - it's a named cell, where I store path for my exported file. Ideally I would want a reference to that cell, instead of typing path in vba, as I showed in my post. About the 2nd part - I tried saving as xlsx - and received error message when opened saved file - "Excel cannot open file, because extension or format is not valid" and was unable to open it... — Hell-1931

FaneDuru FaneDuru · Accepted Answer · 2020-08-21T09:09:59

Try the next code, please:

Private Sub Workbook_Open()
  Dim wb As Workbook, shC As Worksheet
  Dim sh As Worksheet, i As Long, strBackup As String, arr As Variant
  
  Set shC = ThisWorkbook.ActiveSheet 'this should be clear...
  strBackup = Range(ThisWorkbook.Names("BackupPath")).Value 'extract the string from the named range
  Set wb = Workbooks.Add             'open a new workbook
   shC.Copy before:=wb.Worksheets(1) 'copy the active sheet before the existing one
   If wb.Worksheets.Count > 1 Then
        'delete all sheets, except the first
        For i = wb.Worksheets.Count To 2 Step -1
          Application.DisplayAlerts = False
            wb.Worksheets(i).Delete
          Application.DisplayAlerts = False
        Next i
   End If
   arr = Split(strBackup, ".") 'split the path on the dot "."
                               'the last array element will be extension
   arr(UBound(arr)) = "xlsx"   'change exiting extension with "xlsx"
   strBackup = Join(arr, ".")  'join the processed array and obtain the correct path
   wb.SaveAs strBackup, xlWorkbookDefault 'save the workbook
   wb.Close False                         'close it without saving
   
   MsgBox "A backup has been done, like " & strBackup
End Sub

Creating a backup copy of Active Sheet using Excel vba

2 Answers