this dose not do exactly what your asking, it saves the
whole file to a bu directory, adjust it to fit your needs
Sub CreateBackUp()
'need to creat the folder Bu if not their
Dim Num As Integer
Dim OrgPathSt As String
Const BUPath As String = "C:\BU\"
Dim BUPathName As String
Dim Wb As Workbook
On Error GoTo CreateDir
Application.ScreenUpdating = False
Set Wb = ActiveWorkbook
OrgPathSt = Wb.Path & "\" & Wb.Name
If Left(OrgPathSt, 1) = "\" Then
MsgBox "You must name & save your file first,
Via 'File' then 'Save As'"
Exit Sub
End If
BUPathName = "C:\BU\" & Left(Wb.Name, Len(Wb.Name) -
4) & _
" (" & Year(Date) & "-" & Month(Date) & "-" & Day
(Date) & " " & Hour(Time) & "." & Minute(Time) & "." &
Second(Time) & ")" & ".xls"
Num = MsgBox("Do you wish to save the Current file
as:" & vbNewLine & "[ " & OrgPathSt & " ]" _
& vbNewLine & vbNewLine & "And Create the Backup
File:" & vbNewLine & "[ " & BUPathName & " ]",
vbOKCancel, "Back Up")
If Num = vbCancel Then Exit Sub
Wb.Save
SaveAsBu:
Wb.SaveAs FileName:=BUPathName
Wb.Close
Workbooks.Open FileName:=OrgPathSt
Application.ScreenUpdating = True
Exit Sub
CreateDir:
MkDir "BU"
GoTo SaveAsBu
End Sub