New Excel Forum

This forum has been moved to

Ask all future questions in the New Excel Forum.


Prepare Workbooks for Archiving and Save in Archival Folder

Free Excel Macros

Prepare Workbooks for Archiving and Save in Archival Folder

Postby SamT » Mon May 13, 2013 1:57 pm

When a workbook contains formulas with outside references and the outside references change, the values in a workbook may also change.

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:-
  1. Copy the Code.
  2. Paste the copied code into your own workbook’s ThisWorkbook class module.
  3. 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.)
  4. 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: _

''''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
  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.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
Private Function IsTrue()
If Not IsTrue Then IsTrue = Not IsTrue
End Function
Excel Junkie
Posts: 288
Joined: Feb 28, 2013
Location: Missouri, USA
Reputation: 24
Excel Version: 97+XP+2007+2013

Return to Excel Macros

Who is online

Users browsing this forum: No registered users and 7 guests