G
Guest
I am trying to create a macro that will save a copy of a file as an archive,
using the filename and year as eg(06). It then needs to delete all worksheet
links. The workbook contains three sheets called priority , bud, and eval and
these have links to other workbooks that I want to remove for archiving.
I've scoured this message board and gotten so far but i know i'm doing
something wrong and probably not doing it right. I know its also missing
errorr handing. Any help appreciated.
code as follows
Sub createarchive()
CurrentPath = CurDir
ArchivePath = "C:\SMT\archive\plans\"
workbookname = Active.Workbook.Name
mydate = Year(Now)
Fname = ArchivePath + mydate + workbookname
bmessage = "Do you wish to archive this priority and exit?"
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = bmessage
Style = vbYesNo + vbExclamation + vbDefaultButton1 ' Define buttons.
Title = "Archive" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
ActiveWorkbook.Save
Sheets("Priority 1").Select
ActiveWorkbook.SaveAs Filename:=Fname
ActiveSheet.Buttons.Visible = False
ActiveSheet.Unprotect "123"
Sheets("Bud").Select
ActiveSheet.Unprotect "123"
Sheets("Plan Evaluation").Select
ActiveSheet.Buttons.Visible = False
ActiveSheet.Unprotect "123"
ActiveWorkbook.BreakLink Name:="C:\SMT\strat\strat.xls",
Type:=xlExcelLinks
ActiveWorkbook.BreakLink Name:="C:\SMT\plans\yearf\budget\finan.xls",
Type:=xlExcelLinks
Sheets("Priority 1").Select
ActiveSheet.Protect "123"
Sheets("Bud").Select
ActiveSheet.Protect "123"
Sheets("Plan Evaluation").Select
ActiveSheet.Protect "123"
Sheets("Priority 1").Select
ActiveWorkbook.Save
MsgBox "A copy of this Target has been saved for archive purposes"
ActiveWorkbook.Close
Application.Exit
Else ' User chose No.
MsgBox ("Archive ABORTED - no backup made")
Exit Sub
End If
End Sub
using the filename and year as eg(06). It then needs to delete all worksheet
links. The workbook contains three sheets called priority , bud, and eval and
these have links to other workbooks that I want to remove for archiving.
I've scoured this message board and gotten so far but i know i'm doing
something wrong and probably not doing it right. I know its also missing
errorr handing. Any help appreciated.
code as follows
Sub createarchive()
CurrentPath = CurDir
ArchivePath = "C:\SMT\archive\plans\"
workbookname = Active.Workbook.Name
mydate = Year(Now)
Fname = ArchivePath + mydate + workbookname
bmessage = "Do you wish to archive this priority and exit?"
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = bmessage
Style = vbYesNo + vbExclamation + vbDefaultButton1 ' Define buttons.
Title = "Archive" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
ActiveWorkbook.Save
Sheets("Priority 1").Select
ActiveWorkbook.SaveAs Filename:=Fname
ActiveSheet.Buttons.Visible = False
ActiveSheet.Unprotect "123"
Sheets("Bud").Select
ActiveSheet.Unprotect "123"
Sheets("Plan Evaluation").Select
ActiveSheet.Buttons.Visible = False
ActiveSheet.Unprotect "123"
ActiveWorkbook.BreakLink Name:="C:\SMT\strat\strat.xls",
Type:=xlExcelLinks
ActiveWorkbook.BreakLink Name:="C:\SMT\plans\yearf\budget\finan.xls",
Type:=xlExcelLinks
Sheets("Priority 1").Select
ActiveSheet.Protect "123"
Sheets("Bud").Select
ActiveSheet.Protect "123"
Sheets("Plan Evaluation").Select
ActiveSheet.Protect "123"
Sheets("Priority 1").Select
ActiveWorkbook.Save
MsgBox "A copy of this Target has been saved for archive purposes"
ActiveWorkbook.Close
Application.Exit
Else ' User chose No.
MsgBox ("Archive ABORTED - no backup made")
Exit Sub
End If
End Sub