This application was written for those who need to store the a workbook with permanent values from a workbook with formulas that contain outside references.
The application has a means to set several workbooks that it is not allowed to run on. It allows for the setting of an Archival Folder that the modified workbook should be saved to. It does not actually change the original workbook, it only saves the modified copy. It provides a method of adding two customizable strings to the name of the modified Archival workbook. For example; A date sortable string as a prefix and a suffix like "_Archived."
To install the system in your own project please follow these steps:-
- Copy the Code.
- Paste the copied code into your own workbook’s ThisWorkbook class module.
- If your workbook didn’t have any code before, remember that it must now be saved as macro enabled, with an xlsm extension in Excel 2007 or later. (This program is also suitable for use in Excel 2002 and above.)
- Done.
To Run the Macro, Use the Excel Macro Menu
- Code: Select all
Option Explicit
Sub PrepareMeForArchiving()
'Removes all external referencesFrom Active Workbook, _
Renames with prefix and/or suffix, _
Saves in selected Archive Folder. _
Allows forbidding running Macro on various workbooks.
'
'By SamT @
'
'Originally prepared in answer to Igillman: _
http://www.excelkey.com/forum/viewtopic.php?f=3&t=3423&sid=27d5e2c8b74a88787bd2f4ac99d0d3a0
''''Set Book and Sheet variables
Dim WkBk As Workbook
Set WkBk = ActiveWorkbook
Dim Sht As Worksheet
''''Set Posssible Date Strings
Dim SortByDate As String
SortByDate = Format(Now, "yyyy, mm, dd")
Dim USDate As String
USDate = Format(Now, "MMM, dd, yy")
Dim UKDate As String
UKDate = Format(Now, "DDD, mm, yy")
Dim OtherDate As String 'Rename as desired
'OtherDate = Format(Now, "?, ?, ?") 'Set as needed
''''Set Prefix & Suffix to use in Archival book Name
Dim Prefix As String
Prefix = SortByDate 'Assign prefered Archival Name Prefix here
Dim Suffix As String
Suffix = "_Archival" 'Assign prefered Archival Name Suffix here.
'''' Set where to store Archived Workbooks
Dim ArchivalPath As String
'Assign as desired
ArchivalPath = ActiveWorkbook.Path & "\" '= same folder as original.
'Note final spath seperator
''''Set Forbidden Books. Follow example carefully.
Dim ForbiddenBooks As New Collection
With ForbiddenBooks
.Add True, "Insert Master Template Name.xls here with quotes"
'.Add True, "Name of ForbiddenBook2"
'.Add True, "Name of forbiddenBook3" 'etc.
End With
''''Is Macro running on Forbidden Book?
On Error Resume Next
If Not ForbiddenBooks(WkBk.Name) Then
GoTo GoodBook 'If name not in collection, error occurs,
Else 'Name was in collection
MsgBox "You are not allowed to run this macro on " & WkBk.Name
Exit Sub
GoodBook:
End If
''''Prepare and show warning message dialog.
Dim Msg As String
Dim Response As Integer
Msg = "Click ""Yes"" to replace all formulas in this Estimate with" & Chr(13) & _
"their current results and/or values. Otherwise, click ""No."""
Const msgTitle As String = "Archival Preparation"
Const msgButtons As Long = 4388 'Question Mark + Yes&No Buttons + No is default.
'Make sure User wants to remove formulas. 6 = Yes.
Response = MsgBox(Msg, msgButtons, msgTitle)
If Response <> 6 Then Exit Sub
''''Prepare book for Archival
Application.ScreenUpdating = False 'No Screen flickering.
For Each Sht In WkBk.Sheets
Sht.UsedRange.Cells.Copy
Sht.UsedRange.PasteSpecial xlPasteValues
Sht.UsedRange.PasteSpecial xlPasteFormats
Sht.UsedRange.PasteSpecial xlPasteColumnWidths
Next Sht
Application.ScreenUpdating = True
''''ActiveBook SaveAs in ArchivalPath, but with (selected above) suffix and Prefix.
WkBk.SaveAs (ArchivalPath & WkBk.Name & Suffix)
'''SaveAs With Prefix
'WkBk.SaveAs (ArchivalPath & Prefix & " " & WkBk.Name & Suffix) 'Includes Space character example
'''Prefix and Suffix can appear anywhere
'WkBk.SaveAs (ArchivalPath & Suffix & WkBk.Name & Prefix)
End Sub