tente esse, é um código feito pelo AalexandreVBA que eu adaptei à minha necessidade, incluindo data:

Sub Copia_com_Data_AleVBA_GT()
Dim awb2 As Workbook, BackupFileName2 As String, i2 As Integer, OK2 As Boolean, Data As String, Invasor As String
    Data = Replace(Date, "/", "")
    Set awb2 = ActiveWorkbook
    BackupFileName2 = awb2.FullName
        i2 = 0
    While InStr(i2 + 1, BackupFileName2, ".") > 0
        i2 = InStr(i2 + 1, BackupFileName2, ".")
    Wend
    If i2 > 0 Then BackupFileName2 = Left(BackupFileName2, i2 - 1)
    BackupFileName2 = BackupFileName2 & "_" & Data & ".xlsm"
    OK2 = False
    On Error GoTo NotAbleToSave
    With awb2
        Application.StatusBar = "Saving this workbook..."
        .Save
        ChDir ThisWorkbook.Path
        Application.StatusBar = "Saving this workbook backup..."
        .SaveCopyAs BackupFileName2
        OK2 = True
    End With
NotAbleToSave:
    Set awb2 = Nothing
    Application.StatusBar = False
    If Not OK2 Then
        MsgBox "Não foi possível fazer o backup.", vbExclamation, ThisWorkbook.Name
    End If
End Sub

gtsalikis resolvido.
valeu a ajuda.
abs