Макрос на создание копии файла

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    shara = "d:\"
    fname = Format(Date, "dd-MM-yyyy") & "_" & ThisWorkbook.Name
    For x = 1 To 1000
        fname1 = Mid(fname, x, 1)
        If fname1 = "." Then
            fname2 = Mid(fname, 1, x - 1)
            GoTo dalshe
        End If
    Next
    fname = fname2 & ".xlsx"
dalshe:
    ThisWorkbook.SaveAs shara & fname
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    shara = "c:\temp\"
    fname = Format(Date, "dd-MM-yyyy") & "_" & ThisWorkbook.Name
    fname = Left(fname, InStrRev(fname, ".")) & "xlsx"
    Sheets.Copy
    ActiveWorkbook.Close True, shara & fname
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    shara = "c:\temp\"
    fname = Format(Date, "dd-MM-yyyy") & "_" & ThisWorkbook.Name
    fname = Left(fname, InStrRev(fname, ".")) & "xlsx"
    Sheets.Copy
    ActiveWorkbook.Sheets(Me.ActiveSheet.Index).Activate
    ActiveWorkbook.Close True, shara & fname
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Const SHARA = "c:\temp\"
Dim fName$, tmpName$
On Error Resume Next
Application.EnableEvents = False
Application.DisplayAlerts = False
tmpName = SHARA & Me.Name & ".tmp"
Me.SaveCopyAs tmpName
With Workbooks.Open(tmpName)
    fName = Format(Date, "dd-MM-yyyy") & "_" & Me.Name
    fName = SHARA & Left(fName, InStrRev(fName, ".")) & "xlsx"
    .SaveAs fName, xlOpenXMLWorkbook, CreateBackup:=False
    .Close 0
End With
Kill tmpName
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub