Making a model read-only

Rainmanne

Board Regular
Joined
Mar 10, 2016
Messages
85
Office Version
  1. 2013
Platform
  1. Windows
I have a model made in Excel with VBA. I am sorry I cannot post it here as it's sensitive. But the model consists of a few worksheets with formulas linked to other worksheets, which are not in the model. All formulas are commented out to avoid errors. When you open the model it asks for another Excel file, copies two worksheet from there, uncomments the formulas that are linked to those two worksheets and asks to save it under a different name.

So I would like to make the model read-only for users. Thye reason for that is not that users might accidentally edit the file, they will not as all worksheets but one with just a big button saying RUN THE MODEL are hidden. The problem is that if when the model has run and offered to pick up a name for the resulted file in the Save As dialog, the user decides to abort, the model saves the resulted file under the same name as the model effectively making the model unusable for the next run.

However, I have run into a few issues when I made the file read-only.

First, there is a dialog box popping up every time you open a file giving an option to make the file editable and I cannot find a way to get rid of it.

Secondly, the resulted file is also saved as read-only but I need it to be saved normally.

Thirdly, when a user aborts the model on the saving result step, they face a Run-time 1004 dialog which might be confusing in terms of what option (End or Debug) to choose and after choosing the End option you still end up with the results in the model file. So when you close the file it still asks you whether you would like to save it. As the file is still Read-only, it gives you an error if you click on save and proposes to save under a different name (Copy of <file name>).

What I am trying to achieve now is a way to protect the model from being accidently saved with the results inside. I keep a master copy of the model so I can restore it any time but when I am away, people would have to wait for my return, which is not very convenient.

While I was writing this post I realised that my code to handle the model could be not very efficient and tweaking it might solve the issues I've got. So I am posting the code of the main macro here.

Rich (BB code):
Sub UploadData()
Dim FileOpenDial As Variant
Dim FileSaveAs As Variant
Dim wb As Workbook
Dim activeWB As Workbook
Dim bFileSaveAs As Boolean
Dim finstart As Range
Dim endcell As Range, startcell As Range
Dim yearsno As Range
Dim numrowsadj As Integer
Dim cdyearsno As Range
Dim numrows As Integer
Dim numrowscd As Integer
Dim c As Range
Dim decimaltab As Range
Dim d As Range

'Optimize Code
  Call OptimizeCode_Begin

Application.DisplayAlerts = False


'Import the data
Set activeWB = Application.ActiveWorkbook
FileOpenDial = Application.GetOpenFilename(FileFilter:="Excel Files (*.XML), *.XML", Title:="Select File To Be Opened")
If FileOpenDial = False Then Exit Sub
Set wb = Workbooks.Open(FileOpenDial)
    Sheets(Array("Data", "Types")).Select
    Sheets(Array("Data", "Types")).Copy Before:=activeWB.Sheets(1)
wb.Close savechanges:=False 'or True

'Save a file
FileSaveAs = Application.GetSaveAsFilename(FileFilter:="Exel Files (*.xlsx), *.xlsx", Title:="Select Name To Save The File")
If FileSaveAs <> False Then
            ActiveWorkbook.Saveas Filename:=FileSaveAs, _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If

Sheets("AB").Visible = True
Sheets("CD").Visible = True
Sheets("tables").Visible = True

'Populate the prefab tables from the imported data
Sheets("AB").Select

'Remove apostrophe from the formulas
For Each c In Range("D1:D250").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'FillRight Formulas
Set yearsno = ThisWorkbook.Sheets("Data").Range("F2:Z2")
numrows = Application.WorksheetFunction.CountA(yearsno)
    If 5 - numrows >= 0 Then
        numrowsadj = 0
    Else: numrowsadj = 5 - numrows
    End If

With ThisWorkbook.Sheets("AB")
    Set startcell = .Range("D1")
    Set endcell = Cells(Range("D" & Rows.Count).End(xlUp).Row, 3 + numrows + numrowsadj)
    Set finstart = .Range(startcell.Address & ":" & endcell.Address)
    finstart.FillRight
End With

Sheets("CD").Select

'Remove apostrophe from the formulas
For Each c In Range("F1:F160").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'FillRight Formulas
Set cdyearsno = ThisWorkbook.Sheets("AB").Range("C1:XFD1")
numrowscd = Application.WorksheetFunction.CountA(cdyearsno)

With ThisWorkbook.Sheets("CD")
    Set startcell = .Range("F1")
  
    If numrowscd = 3 Then
        Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 1)
        Set finstart = .Range(startcell.Address & ":" & endcell.Address)
        finstart.FillRight
    ElseIf numrowscd > 3 Then
        Set endcell = Range("F" & Rows.Count).End(xlUp).Offset(, 2)
        Set finstart = .Range(startcell.Address & ":" & endcell.Address)
        finstart.FillRight
    Else
    End If
End With

'Activite tables
Sheets("tables").Select

For Each c In Range("C1:G150").SpecialCells(xlCellTypeConstants)
    c.Formula = Replace(c.Formula, "'", "")
Next c

'Hide the button
Sheets("Model").Visible = False

'Stop Optimize Code
Call OptimizeCode_End

'Pasting Coloured cells
'Range("E90:E99").Copy
'Range("G90").PasteSpecial Paste:=xlPasteFormats, Transpose:=True

'Formatting
Set decimaltab = [C2:E16,C25:E49,C62:E69,C71:E75,C77:E83,C104:E108,C110:E111,C115:E116,C137:C138]

For Each d In decimaltab.SpecialCells(xlCellTypeFormulas, xlNumbers)
    If Abs(d.Value) < 20 And Round(d.Value, 0) <> 0 Then
        d.NumberFormat = "0.0;(0.0)"
        
   End If
Next d

ThisWorkbook.Worksheets("AB").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit
ThisWorkbook.Worksheets("CD").Cells.SpecialCells(xlCellTypeVisible).EntireColumn.AutoFit

ActiveWorkbook.Save

End Sub
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Candyman8019

Well-known Member
Joined
Dec 2, 2020
Messages
601
Office Version
  1. 365
Platform
  1. Windows
How about if you try saving it as a .xltm (macro-enabled template). This will prevent the user from saving over your master copy...unless they intentionally do so.
 
Upvote 0

Rainmanne

Board Regular
Joined
Mar 10, 2016
Messages
85
Office Version
  1. 2013
Platform
  1. Windows
How about if you try saving it as a .xltm (macro-enabled template). This will prevent the user from saving over your master copy...unless they intentionally do so.
Thankis a lot. Did not think about it. Probably it's an easier option.
 
Upvote 0

Candyman8019

Well-known Member
Joined
Dec 2, 2020
Messages
601
Office Version
  1. 365
Platform
  1. Windows
Just one thing to note, when saving as a template, Windows (at least on my system) ties to save the file in a "custom template" location...so when you're saving the master, make sure you put it in the correct location.
 
Upvote 0

Rainmanne

Board Regular
Joined
Mar 10, 2016
Messages
85
Office Version
  1. 2013
Platform
  1. Windows
Just one thing to note, when saving as a template, Windows (at least on my system) ties to save the file in a "custom template" location...so when you're saving the master, make sure you put it in the correct location.
Thanks a lot! I was just wondering where the file has gone after saving :biggrin:
 
Upvote 0

Rainmanne

Board Regular
Joined
Mar 10, 2016
Messages
85
Office Version
  1. 2013
Platform
  1. Windows
How about if you try saving it as a .xltm (macro-enabled template). This will prevent the user from saving over your master copy...unless they intentionally do so.
Sorry, have remembered the issue I had with this method. If a user opens the model by clicking on the file in File Explorer, it works perfectly as it opens a copy of the model under a slightly different name. However, if a user opens the model from Excel, then it opens the template itself. So in case of aborting the model run on the save as stage, the results will get saved in the model, exactly what I try to avoid.
 
Upvote 0

Candyman8019

Well-known Member
Joined
Dec 2, 2020
Messages
601
Office Version
  1. 365
Platform
  1. Windows
Try something like this:
VBA Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
      If SaveAsUI = True Then 
          if environ("Username") <> "your user ID" then
              Cancel = True
          end if
     end if
End Sub
 
Upvote 0

Forum statistics

Threads
1,186,409
Messages
5,957,674
Members
438,315
Latest member
Simon Robert

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top