Dosyanın belli sayfalarının yedeğini alma

Arkadaşlar merhaba
Öncelikle dosyanın sayfa koruma şifresi "sivas"
Ekli dosyada e okul proğramından alınan öğrenci notlarının kazanım ölçeklerini oluşturuyorum.
Bu dosyanın yedeğini almak istediğimde kaydet ve temizle butonuna tıkladığımda dosyanın yedeğini alıyor ancak dosyadaki verileri ana dosyayla formül bağlantılı olarak yedeklediğinden ana dosyadaki veriler silinince yedeklenen dosyanın da içi boşalmış oluyor.

Yapmak istediğim ise yedek alırken formüllerle değil de formüllerin getirdiği değerlerle yadek alması. Yedekleme kodları aşağıdadır. Bu kodları nasıl revize edebiliriz? Veya aynı işi yapacak bir kod nasıl olmalıdır? Saygılar sunuyorum.

Sub kaydet_temizle()
ActiveSheet.Unprotect "sivas"
Dim s1 As Worksheet, s As Long, kayıt As String, yol As String
Dim deg As String, ad As String
Dim f As Object
Set s1 = Sheets("SINIF")
's1.Range("F10").Value = UCase(Replace(Replace(s1.Range("F10").Value, "ı", "I"), "i", "İ"))
deg = s1.Range("F10").Value
If deg <> "" And s1.Cells(Rows.Count, "C").End(3).Row > 11 Then
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'On Error GoTo fr
Set f = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path & "\"
If f.FolderExists(yol & "Yedek Dosyalar") = False Then f.CreateFolder yol & "Yedek Dosyalar"
ad = f.GetBaseName(ThisWorkbook.Name) & " " & deg
kayıt = yol & "Yedek Dosyalar\" & ad & ".xls"
a = 0
Workbooks.Add 1
For s = 1 To ThisWorkbook.Sheets.Count
SayfaAdi = ThisWorkbook.Sheets(s).Name

a = a + 1
If ThisWorkbook.Sheets.Count <> ActiveWorkbook.Sheets.Count Then ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ThisWorkbook.Sheets(s).Cells.Copy
ActiveWorkbook.Sheets(a).PasteSpecial
Application.CutCopyMode = False
ActiveWorkbook.Sheets(a).Name = ThisWorkbook.Sheets(s).Name

Next
Application.DisplayAlerts = False
ChDir yol & "Yedek Dosyalar\"
ActiveWorkbook.Sheets(1).Activate
ActiveWorkbook.SaveAs Filename:=kayıt, FileFormat:=56
ActiveWorkbook.Close savechanges:=False
MsgBox ad & " dosyası " & vbCrLf & yol & "Yedek Dosyalar Klasörüne kaydedildi"
Application.DisplayAlerts = True

End If
fr:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error Resume Next
s1.Range("C12:AF1000").SpecialCells(xlCellTypeConstants, 23).ClearContents
s1.Range("F10") = ""
ActiveSheet.Protect "sivas"
End Sub