'// Code to be placed in Worksheet module(s)
 
Option Explicit 
 
Private Sub Worksheet_Activate() 
    Application.EnableEvents = False 
    SaveFormat 
    Application.EnableEvents = True 
End Sub 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
    Application.EnableEvents = False 
    GetFormat Target 
    Application.EnableEvents = True 
End Sub 
 
 
 '//Code to be placed in Workbook module
 
Option Explicit 
 
Private Sub Workbook_Open() 
    Application.EnableEvents = True 
    FreezeChanges 
End Sub 
 
Private Sub Workbook_Beforeclose(Cancel As Boolean) 
    Dim sh As Worksheet 
    Application.DisplayAlerts = False 
    For Each sh In Sheets 
        If Right(sh.Name, 7) = "Formats" Then sh.Delete 
    Next 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 
    ActiveWorkbook.Save 
End Sub 
 
 '//Code to be placed in Standard module
 
 
Option Explicit 
 'You need to use the Permit Formatting Changes before changing any
 'formats and then Freeze, otherwise the changes will not hold.
 'This function is intended as a protection of a "Final Version"
 'where format changes would be infrequent.
 
Sub FreezeChanges() 
    SaveFormat 
    [D3] = "Format frozen" 
    Application.EnableEvents = True 
End Sub 
 
Sub PermitChanges() 
    Application.EnableEvents = False 
    Application.DisplayAlerts = False 
    On Error Resume Next 
    Sheets(ActiveSheet.Name & "Formats").Delete 
    [D3] = "Changes permitted" 
    Application.DisplayAlerts = True 
End Sub 
 
Sub SaveFormat() 
    Dim MySht As String, MyAdd As String 
     
    Application.ScreenUpdating = False 
    MySht = ActiveSheet.Name 
    If ShExists(MySht & "Formats") = True Then GoTo DoSave 
    MyAdd = ActiveCell.Address 
    Sheets.Add 
    With ActiveSheet 
        .Name = MySht & "Formats" 
        .Visible = False 
    End With 
DoSave: 
    Sheets(MySht).Cells.Copy 
    Sheets(MySht & "Formats").Range("A1").PasteSpecial Paste:=xlFormats 
     
    Application.CutCopyMode = False 
    Application.ScreenUpdating = True 
End Sub 
 
Sub GetFormat(Target As Range) 
    Dim MySht As String, MyCells As Range 
     
    Set MyCells = Selection 
    Application.ScreenUpdating = False 
    MySht = ActiveSheet.Name 
    Sheets(MySht & "Formats").Cells.Copy 
    Sheets(MySht).Range("A1").PasteSpecial Paste:=xlFormats 
    Application.CutCopyMode = False 
    Application.ScreenUpdating = True 
    MyCells.Select 
End Sub 
 
Function ShExists(ShName As String) As Boolean 
    Dim WS As Worksheet 
    On Error Resume Next 
    Set WS = Sheets(ShName) 
    If WS Is Nothing Then ShExists = False Else ShExists = True 
End Function