VBA Script Error - Run Time Error 1004

suet

Board Regular
Joined
Oct 19, 2005
Messages
56
Hi

I am trying to work out the above error on the attached workbook and have spent hours but to no avail.

ContentsSheet.Protect DrawingObjects:=True, Contents:=False, Scenarios:=True


Could someone please point me in the right direction as I am no expert in VBA and I have been given this task without relevant training.

Thanking you all in advance.

Kind Regards

Sue
 

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.
Hi,
On it's own, That line of code (after I set your object variable ContentsSheet to a worksheet), worked ok for me.

Helpful if you publish all the code which should help forum resolve your issue

Dave
 
Last edited:
Upvote 0
What is the error message?


In the forum you cannot attach files but you can upload it to the cloud:

You could upload a copy of your file to a free site such www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0
Hi Dante

Thank you for your help with this problem.

Links to both spreadsheets listed below;

https://www.dropbox.com/s/r37b9uzp0ouamsv/Abbeyfield House_password abc.xlsm?dl=0

https://www.dropbox.com/s/ckjy7icxqxt1pyx/Maydew House_password abc.xlsm?dl=0

Regards

Sue



What is the error message?


In the forum you cannot attach files but you can upload it to the cloud:

You could upload a copy of your file to a free site such www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.
 
Upvote 0
Hi Dante

Thank you for your help with this problem.

Links to both spreadsheets listed below;
Regards

Sue

In your file I don't see a sheet called "ContentsSheet", I also can't find in the code where you set any sheet for the "ContentsSheet" object


You have this:


Code:
[B][COLOR=#ff0000]ContentsSheet[/COLOR][/B].Protect DrawingObjects: = True, Contents: = False, Scenarios: = True

But somewhere in the code you must set some sheet for the ContentsSheet object


Again:
What does the error message say?
 
Upvote 0
Hi Dante

I am completely out of my depth here.

I have absolutely no idea about coding and VBA.

I have copied all the coding in the hope you may be able to guide me further.

See code below:


Code:
Sub OLUIR(ribbon As IRibbonUI)

    On Error Resume Next
        ribbon.ActivateTab "Cost_Plan"
End Sub

Sub HelpMessage(help_text, subtitle, icon, sheet_name)

'This is used to create the message box displayed when the "how to use" or "help on this page" buttons are clicked

'Default text to use for basic "How to Use" dialogue box
'=======================================================
If help_text = 0 Then
    help_text = "GENERAL INFORMATION" _
        & vbNewLine & vbNewLine & "This workbook should be used for the preparation of elemental cost plans from detailed design information. " _
        & "If detailed information is not available, the Order of Cost Estimate template should be used instead." _
        & vbNewLine & vbNewLine & "Before proceeding, you should be familiar with the calfordseaden Estimating Guidance note and " _
        & "the RICS's New Rules of Measure-" _
        & vbNewLine & "ment 1: Order of Cost Estimating and Elemental Cost Planning for Capital Building Works." _
        & vbNewLine & vbNewLine & "If you are not familiar with these documents please speak to David Cane or a Quantity Surveyor member of staff." _
        & vbNewLine & vbNewLine & "BUILT-IN ASSISTANCE" _
        & vbNewLine & vbNewLine & "The workbook contains a number of automated functions to help with formatting the document and " _
        & "contains named ranges which link data in sheets together, which should be maintained." _
        & vbNewLine & vbNewLine & "In the Cost Plan ribbon tab are buttons that you can click for additional help on the specific sheets or to " _
        & "operate the automated functions." _
        & vbNewLine & vbNewLine & "Continued..."
End If
If help_text = 1 Then
    help_text = "OPTIONAL ITEMS" _
        & vbNewLine & vbNewLine & "Throughout the workbook there are items that will need to be customised to suit your project:          " _
        & vbNewLine & vbNewLine & "1. Review and complete the assumptions and exclusions lists." _
        & vbNewLine & "2. Add a list of drawings and other documents used into the assumptions list." _
        & vbNewLine & "3. Modify and adapt the area schedule and accommodation schedule to suit your project." _
        & vbNewLine & vbNewLine & "Optional or placeholder text to be checked is enclosed in square brackets [ ]." _
        & vbNewLine & vbNewLine & "Optional sheets include a comparison sheet for comparing an estimate with a previous version and a " _
        & "spare blank sheet to be used as the basis for any additional sections that need to be added."
End If
If help_text = 2 Then
    help_text = "The " & sheet_name & " worksheet cannot be found." _
        & vbNewLine & vbNewLine & "For the proper operation of the workbook the worksheets should not be deleted. You will need to copy this worksheet from another version of this template or start again."
End If
If subtitle = 0 Then
    subtitle = "How to Use"
End If
If icon = 0 Then
    icontext = vbOKOnly + vbInformation
End If

'Other Subtitle and icon settings
'================================

If subtitle = 1 Then
    subtitle = "Missing Worksheet Error"
End If
If icon = 1 Then
    icontext = vbOKOnly + vbCritical
End If

'Display help message box
'========================

m = MsgBox(help_text, icontext, "Elemental Cost Plan - " & subtitle)
End Sub

Private Sub How_to_Use(control As IRibbonControl)

Call HelpMessage(0, 0, 0, 0)
Call HelpMessage(1, 0, 0, 0)

End Sub

Private Sub Cover_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet2.Visible = True
Sheet2.Activate

HelpMessage "Enter the Project Name, Client Name, Date and document reference where indicated." & vbNewLine & vbNewLine _
    & "The Project Name will appear at the head of each sheet." & vbNewLine & vbNewLine _
    & "Click on the Set Footers button to insert the document reference" & vbNewLine _
    & "and date into each sheet." & vbNewLine & vbNewLine _
    & "When the estimate has been reviewed, complete the sign-off section.", "Cover", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Cover")

MacroEnd:

End Sub

Private Sub Spare_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet14.Visible = True
Sheet14.Activate

HelpMessage "Use this sheet to create any extra pages that you need." _
    & vbNewLine & vbNewLine & "So that this page appears in the contents list, remove" _
    & vbNewLine & "the leading x from the tab name.", "Spare Sheet", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Spare Sheet")

MacroEnd:

End Sub

Private Sub Contents_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
ContentsSheet.Visible = True
ContentsSheet.Activate

HelpMessage "The contents list and numbering are created automatically" _
    & vbNewLine & "when the Create Contents button is clicked.", "Contents", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Contents")

MacroEnd:

End Sub

Private Sub Summary_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet4.Visible = True
Sheet4.Activate

HelpMessage "The summary is compiled automatically from the estimate sheet. " _
    & vbNewLine & "Only the percentages for the on-costs and the inflation need to" _
    & vbNewLine & "be entered.", "Summary", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Summary")

MacroEnd:

End Sub

Private Sub Assumptions_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet5.Visible = True
Sheet5.Activate

HelpMessage "It is important that the list of assumptions is filled out in detail." _
    & vbNewLine & "For the client and the design team to understand the basis of the," _
    & vbNewLine & "estimate they must know what has been assumed." _
    & vbNewLine & vbNewLine & "Enter details of the assumptions used for pricing the substructure," _
    & vbNewLine & "frame, ground conditions, contamination, etc." _
    & vbNewLine & vbNewLine & "State what has been assumed for the tender and start on site" _
    & vbNewLine & "dates and how inflation has been calculated, if included." _
    & vbNewLine & vbNewLine & "Lists of the drawings with revisions numbers and titles must be" _
    & vbNewLine & "included together with any other reports." _
    & vbNewLine & vbNewLine & "If a choice between alternative options has had to be made, state" _
    & vbNewLine & "which was selected.", "Assumptions", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Assumptions")

MacroEnd:

End Sub

Private Sub Exclusions_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet6.Visible = True
Sheet6.Activate

HelpMessage "It is important that the lists of exclusions are filled out in detail." _
    & vbNewLine & "For the client and the design team to understand the basis of the," _
    & vbNewLine & "estimate they must know what has been included and excluded." _
    & vbNewLine & vbNewLine & "There are two lists of exclusions:" _
    & vbNewLine & vbNewLine & "1. Excluded items that will cost the client money - to be paid from" _
    & vbNewLine & "    other budgets" _
    & vbNewLine & "2. Excluded items that may cost the client money - to be covered" _
    & vbNewLine & "    by contingencies" _
    & vbNewLine & vbNewLine & "Examples of the two types are included in the default lists, which" _
    & vbNewLine & "must be reviewed and amended to suit project specifics.", "Exclusions", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Exclusions")

MacroEnd:

End Sub

Private Sub Estimate_Help(control As IRibbonControl)

On Error GoTo ErrorTrap

If SecretSheet.Range("F1").Value = "Full" Then
    Sheet7.Visible = True
    Sheet7.Activate
    HelpMessage "This is where the detailed build-up of the estimate is prepared." _
    & vbNewLine & vbNewLine & "The layout follows the format of New Rules of Measurement 1, 2nd edition (NRM1) with four levels of classification in accordance with the hierarchy of Group Element, Element, Sub-element " _
    & vbNewLine & "and Component." _
    & vbNewLine & vbNewLine & "The default descriptions and code numbers correspond to the NRM1 hierarchy. The descriptions will need to be altered to suit" _
    & vbNewLine & "the circumstances, but the numbers must be maintained in accordance with the hierarchy to ensure that the elemental" _
    & vbNewLine & "breakdown structure is maintained and the costs are correctly allocated on the summary sheet. It is not necessary for the" _
    & vbNewLine & "numbers to be sequential and there may be more than one of each. Any items that are not required may be deleted or hidden." _
    & vbNewLine & vbNewLine & "Missing code numbers in the first and last columns will be identified by a warning at the top of the page and in the Element column.", "Estimate", 0, 0
ElseIf SecretSheet.Range("F1").Value = "Simplified" Then
    Sheet16.Visible = True
    Sheet16.Activate
    HelpMessage "This is where the detailed build-up of the estimate is prepared." _
    & vbNewLine & vbNewLine & "The layout follows the format of New Rules of Measurement 1, 2nd edition (NRM1) with three levels of classification in accordance with the hierarchy of Group Element, Element and Sub-element." _
    & vbNewLine & "Detailed Component level information is not provided in the Simplified breakdown." _
    & vbNewLine & vbNewLine & "The default descriptions and code numbers correspond to the NRM1 hierarchy. The descriptions will need to be altered to suit" _
    & vbNewLine & "the circumstances, but the numbers must be maintained in accordance with the hierarchy to ensure that the elemental" _
    & vbNewLine & "breakdown structure is maintained and the costs are correctly allocated on the summary sheet. It is not necessary for the" _
    & vbNewLine & "numbers to be sequential and there may be more than one of each. Any items that are not required may be deleted or hidden." _
    & vbNewLine & vbNewLine & "Missing code numbers in the first and last columns will be identified by a warning at the top of the page and in the Element column.", "Estimate", 0, 0
ElseIf SecretSheet.Range("F1").Value = "Very Simplified" Then
    Sheet17.Visible = True
    Sheet17.Activate
    HelpMessage "This is where the detailed build-up of the estimate is prepared." _
    & vbNewLine & vbNewLine & "The layout follows the format of New Rules of Measurement 1, 2nd edition (NRM1) with two levels of classification in accordance with the hierarchy of Group Element and Element." _
    & vbNewLine & "Sub-element and Detailed Component level information is not provided in the Very Simplified breakdown." _
    & vbNewLine & vbNewLine & "The default descriptions and code numbers correspond to the NRM1 hierarchy. The descriptions will need to be altered to suit" _
    & vbNewLine & "the circumstances, but the numbers must be maintained in accordance with the hierarchy to ensure that the elemental" _
    & vbNewLine & "breakdown structure is maintained and the costs are correctly allocated on the summary sheet. It is not necessary for the" _
    & vbNewLine & "numbers to be sequential and there may be more than one of each. Any items that are not required may be deleted or hidden." _
    & vbNewLine & vbNewLine & "Missing code numbers in the first and last columns will be identified by a warning at the top of the page and in the Element column.", "Estimate", 0, 0
End If

Exit Sub

ErrorTrap:

If SecretSheet.Range("F1").Value = "Full" Then
    Call HelpMessage(2, 1, 1, "Estimate")
ElseIf SecretSheet.Range("F1").Value = "Simplified" Then
    Call HelpMessage(2, 1, 1, "Simplified Estimate")
ElseIf SecretSheet.Range("F1").Value = "Very Simplified" Then
    Call HelpMessage(2, 1, 1, "Very Simplified Estimate")
End If

End Sub

Private Sub Definitions_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet10.Visible = True
Sheet10.Activate

HelpMessage "This sheet contains defintions of terms used throughout " _
    & vbNewLine & "the estimate. Its inclusion is optional." _
    & vbNewLine & vbNewLine & "So that this page appears in the contents list, remove" _
    & vbNewLine & "the leading x from the tab name.", "Definitions Sheet", 0, 0
    
GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Definitions")

MacroEnd:

End Sub

Private Sub Fees_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet12.Visible = True
Sheet12.Activate

HelpMessage "This sheet contains NRM-structured schedules for the following types of fees: " _
    & vbNewLine & vbNewLine & "11.1  Consultants' fees" _
    & vbNewLine & "11.2  Pre-construction fees" _
    & vbNewLine & "11.3  Design fees" _
    & vbNewLine & vbNewLine & "If a detailed schedule of fees is available or required, this may be used instead " _
    & "of a percentage-based allowance on the Summary sheet. Delete any sub-elements that are not used." _
    & vbNewLine & vbNewLine & "To include the sums on this schedule in the Summary, set the answer to the question box on the Summary sheet to 'Yes'." _
    & vbNewLine & vbNewLine & "So that this page appears in the contents list, remove the" _
    & vbNewLine & "leading x from the tab name.", "Fees Sheet", 0, 0
    
GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Fees Sheet")

MacroEnd:

End Sub
Private Sub Other_Costs_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet13.Visible = True
Sheet13.Activate

HelpMessage "This sheet contains an NRM-structured schedule for Other Development/Project Costs." _
    & vbNewLine & vbNewLine & "If a detailed schedule of Other Development/Project Costs is available or required, this may be used instead " _
    & "of a percentage-based allowance on the Summary sheet. Delete any sub-elements that are not used." _
    & vbNewLine & vbNewLine & "To include the sums on this schedule in the Summary, set the answer to the question box on the Summary sheet to 'Yes'." _
    & vbNewLine & vbNewLine & "So that this page appears in the contents list, remove the" _
    & vbNewLine & "leading x from the tab name.", "Other Development/Project Costs Sheet", 0, 0
    
GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Other Development/Project Costs Sheet")

MacroEnd:

End Sub

Private Sub Areas_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet8.Visible = True
Sheet8.Activate
HelpMessage "The default area schedule provided here will need to be modified to suit the project." _
        & vbNewLine & vbNewLine & "Ensure that the cell containing the total gross internal area is named ""gia_total"" as this is linked to elsewhere." _
        & vbNewLine & vbNewLine & "State the source of the areas (e.g. advised by architect or measured from drawings).", "Area Schedule", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Area Schedule")

MacroEnd:

End Sub


Private Sub Accommodation_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet9.Visible = True
Sheet9.Activate
HelpMessage "The default accommodation schedule provided here will need to be modified to suit the project." _
        & vbNewLine & vbNewLine & "Ensure that the cell containing the total units is named ""units_total"" as this is linked to elsewhere." _
        & vbNewLine & vbNewLine & "State the source of the areas (e.g. advised by architect or counted from drawings).", "Accommodation Schedule", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Accommodation Schedule")

MacroEnd:

End Sub

Private Sub Comparison_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet11.Visible = True
Sheet11.Activate
HelpMessage "Use this page if a previous estimate was produced" & vbNewLine _
    & "that you want this one to be compared against." _
    & vbNewLine & vbNewLine & "So that this page appears in the contents list, remove" _
    & vbNewLine & "the leading x from the tab name.", "Comparison", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Comparison")

MacroEnd:

End Sub

Private Sub Calculations_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
Sheet15.Visible = True
Sheet15.Activate
HelpMessage "Use this sheet to store any calculations that you need." & vbNewLine & vbNewLine _
    & "This page will not be shown in the contents list and should not be issued.", "Calculations", 0, 0

GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Calculations")

MacroEnd:

End Sub

Private Sub Help_on_Named_Ranges(control As IRibbonControl)

HelpMessage "Using named ranges allows a cell or a range of cells on a spreadsheet to be referenced in a formula with " _
    & "a name rather than a cell reference, this makes formulas much easier to follow. This workbook uses several named ranges." _
    & vbNewLine & vbNewLine & "To create a name, select the cell or group of cells you wish to name and click on the Name Box at the top " _
    & "left of the formula bar, where the cell address is shown. Then type a name without spaces and press return." _
    & vbNewLine & vbNewLine & "To use a name in a formula, start typing a name and a dropdown list will appear. Double click on the " _
    & "name and it will be inserted into the formula.", "Using Named Ranges", 0, 0

End Sub


Private Sub Comparison_Setup(control As IRibbonControl)
'
' Copies data from the "This estimate" column to the "Previous estimate" column.

msg1 = MsgBox("This will copy the values from the ""This Estimate"" column to the ""Previous Estimate"" column." & vbNewLine & vbNewLine & _
    "This should be done before you make any changes so that the difference is accurately shown." & vbNewLine & vbNewLine & _
    "If you have already made changes, click No and enter the previous estimate values manually." & vbNewLine & vbNewLine & _
    "Do you want to continue?", vbYesNo + vbExclamation + vbDefaultButton2, "Elemental Cost Plan - Setup Comparison Table")

If msg1 = vbYes Then Call Comparison_Setup_Action

End Sub

Sub Comparison_Setup_Action()

' Copies data from the "This estimate" column to the "Previous estimate" column.

On Error GoTo ErrorHandler

Errloc = 0
Sheet11.Visible = True
Sheet11.Activate

Errloc = 2
'Get details of current selection
'================================
thisRow = ActiveCell.Row
thisCol = ActiveCell.Column

'Copy & Paste values
'===================
Errloc = 3
Application.ScreenUpdating = False  'turn off screenupdating
Range("C8:C11").Select
Selection.Copy
Range("E8:E11").Select
Selection.PasteSpecial Paste:=xlValues

Range("C15:C23").Select
Selection.Copy
Range("E15:E23").Select
Selection.PasteSpecial Paste:=xlValues

Range("C26:C28").Select
Selection.Copy
Range("E26:E28").Select
Selection.PasteSpecial Paste:=xlValues

Range("C32:C35").Select
Selection.Copy
Range("E32:E35").Select
Selection.PasteSpecial Paste:=xlValues

Range("C39:C53").Select
Selection.Copy
Range("E39:E53").Select
Selection.PasteSpecial Paste:=xlValues

Range("C57").Select
Selection.Copy
Range("E57").Select
Selection.PasteSpecial Paste:=xlValues

Range("C61:C66").Select
Selection.Copy
Range("E61:E66").Select
Selection.PasteSpecial Paste:=xlValues

Range("C70:C77").Select
Selection.Copy
Range("E70:E77").Select
Selection.PasteSpecial Paste:=xlValues

Range("C81:C85").Select
Selection.Copy
Range("E81:E85").Select
Selection.PasteSpecial Paste:=xlValues

Range("C91").Select
Selection.Copy
Range("E91").Select
Selection.PasteSpecial Paste:=xlValues

Range("C95").Select
Selection.Copy
Range("E95").Select
Selection.PasteSpecial Paste:=xlValues

Range("C99:C101").Select
Selection.Copy
Range("E99:E101").Select
Selection.PasteSpecial Paste:=xlValues

Range("C107").Select
Selection.Copy
Range("E107").Select
Selection.PasteSpecial Paste:=xlValues

Range("C113:C116").Select
Selection.Copy
Range("E113:E116").Select
Selection.PasteSpecial Paste:=xlValues

Range("C122").Select
Selection.Copy
Range("E122").Select
Selection.PasteSpecial Paste:=xlValues

Range("C126").Select
Selection.Copy
Range("E126").Select
Selection.PasteSpecial Paste:=xlValues

Application.CutCopyMode = False
    
'Reposition active cell
'======================
Sheet11.Cells(thisRow, thisCol).Select
Application.ScreenUpdating = True  'turn on screenupdating

'Change Sheet Name
'================

If Left(Sheet11.Name, 1) = "x" Then
    Sheet11.Name = Right(Sheet11.Name, Len(Sheet11.Name) - 1)
End If

GoTo MacroEnd

ErrorHandler:

If Errloc = 0 Then
    Call HelpMessage(2, 1, 1, "Comparison")
Else
    error_msg = MsgBox("An error has occurred and the comparison table could not be amended." & vbNewLine & vbNewLine & _
    "You will have to amend the table manually." & vbNewLine & vbNewLine & _
    "Error code: " & Errloc & ".", vbOKOnly + vbCritical, "Order of Cost Estimate - Comparison Setup - Error")
End If

MacroEnd:
    
End Sub


Sub Create_Contents(control As IRibbonControl)

Call Create_Contents_Action(1)

End Sub

Sub Create_Contents_Action(show_message)

'Creates the contents list by reading the section titles and counting the number of pages in the document

'On Error GoTo ErrorHandler

Errloc = -1

ContentsSheet.Visible = True
ContentsSheet.Activate

'Set variables
'=============
cPB = 0 'count of page breaks/page ends
cSht = ActiveWorkbook.Worksheets.Count
startSht = 4   'first sheet in workbook after contents page
sectnum = 1 'number of first section
r = 7   'first row in Contents page for list to start on
thisSht = ContentsSheet.Name  'gets name of Contents sheet to see if it has been changed
Errloc = 0

'Messages
'========

Errloc = 1

If showmesage = 1 Then
    msg1 = MsgBox("This will create the Contents list for the document." & vbNewLine & vbNewLine & _
        "Ensure the following:" & vbNewLine & vbNewLine & "1. Cover page sheet is first sheet in workbook." & vbNewLine & _
        "2. " & thisSht & " sheet is second sheet in the workbook." & vbNewLine & _
        "3. All sheets are set to fit to one page wide." & vbNewLine & _
        "4. All sheets have a title in cell A4." & vbNewLine & vbNewLine & _
        "To exclude a sheet from the Contents list either hide it" & vbNewLine & _
        "or put ""x"" at the front of its tab name.", _
        vbOKCancel + vbInformation + vbDefaultButton2, "Elemental Cost Plan - Create Contents List")

    If msg1 = vbCancel Then GoTo MacroEnd
End If

Errloc = 2
If ActiveWorkbook.Worksheets(3).Name <> thisSht Then    'checks if the contents sheet is in third position
    msg2 = MsgBox("Contents List sheet is not the second sheet. Please correct before continuing.", _
    vbCritical + vbOKOnly, "Elemental Cost Plan - Create Contents List")
    GoTo MacroEnd
End If

'Clear existing contents list and set status bar message
'=======================================================
Errloc = 3
ContentsWorksheet = Protect
'DrawingObjects:=True, Contents:=False, Scenarios:=True

chkr = 7
While ContentsSheet.Cells(chkr, 1).Value <> ""
    chkr = chkr + 1
Wend
ContentsSheet.Range(Cells(r, 1), Cells(chkr - 1, 3)).Select

Selection.Clear     'clears the existing list
Selection.RowHeight = ActiveSheet.StandardHeight
ContentsSheet.Cells(1, 1).Select    'puts the active cell in the top left corner - also affects the other sheets

Errloc = 4
Application.DisplayStatusBar = True 'forces statusbar to be displayed
Application.StatusBar = "Building contents list..." 'puts text on status bar
Application.ScreenUpdating = False  'turn off screenupdating

'Set page numbering for all pages after contents
'===============================================
Errloc = 5
For foot = startSht To cSht
   If foot = startSht Then
        ActiveWorkbook.Worksheets(foot).PageSetup.FirstPageNumber = 1 'sets the page numbering to start at 1 on the Summary page
   Else
         ActiveWorkbook.Worksheets(foot).PageSetup.FirstPageNumber = xlAutomatic ' sets the page numbering to continue from the previous sheet
   End If
Next foot

'Select all pages - needed because the page breaks are not detected if not in page break view and not selected
'=============================================================================================================
Errloc = 6
For ws = 1 To cSht - 1
    If ActiveWorkbook.Worksheets(ws).Visible = True And Left(ActiveWorkbook.Worksheets(ws).Name, 1) <> "x" Then
        ActiveWorkbook.Worksheets(ws).Select (False) 'extend selection to include next sheet
    End If
Next
ActiveWindow.View = xlPageBreakPreview

'Build contents list
'===================
Errloc = 7
    
For Sht = startSht To cSht
    Errloc = 7.1
    If ActiveWorkbook.Worksheets(Sht).Visible = True And Left(ActiveWorkbook.Worksheets(Sht).Name, 1) <> "x" Then
        cPB = cPB + 1
        Errloc = 7.2
        tSht = ActiveWorkbook.Worksheets(Sht).Range("A3").Value 'gets sheet title from cell A3 in each sheet
        tShtdotpos = InStr(1, tSht, ".")
        If Len(Trim(tSht)) = 0 Then 'if there is no text in the sheet title
            Errloc = 7.3
            tShtname = "[TITLE REQUIRED]"
        ElseIf tShtdotpos = 0 Then 'if there is no dot in the sheet title
            Errloc = 7.4
            tShtname = Trim(tSht)
        ElseIf tShtdotpos <> 0 Then  'if there is a dot in the sheet title
            Errloc = 7.5
            tShtname = Trim(Mid(tSht, tShtdotpos + 2)) 'gets section title
            If Len(Trim(tShtname)) = 0 Then tShtname = "[TITLE REQUIRED]"
        End If
        Errloc = 7.6
        
        tSht = ActiveWorkbook.Worksheets(Sht).Range("A3").Value
        '= sectnum & "." & tShtname  'revises sheet title with new section number
        ContentsSheet.Cells(r, 1).Value = sectnum   'puts number into contents page
        ContentsSheet.Cells(r, 2).Value = tShtname   'puts name into contents page
        ContentsSheet.Cells(r, 3).Value = cPB   'puts page number into contents page
        ContentsSheet.Rows(r).RowHeight = ActiveSheet.StandardHeight * 2    'doubles the row height
        r = r + 1   'increments row in contents page
        sectnum = sectnum + 1 'increments section number in contents page
        Errloc = 7.7
        For Each pb In ActiveWorkbook.Worksheets(Sht).HPageBreaks 'counts the number of horizontal page breaks in the worksheet
            If pb.Type = xlPageBreakAutomatic Or pb.Type = xlPageBreakManual Then
                cPB = cPB + 1
            End If
        Next pb
    End If
Next Sht

ActiveWindow.View = xlNormalView    'restore view of sheets to normal view
ContentsSheet.Select (True)    'select the contents sheet only

'Set print area for contents sheet
'=================================

ContentsSheet.Range(Cells(1, 1), Cells(6 + sectnum - 1, 3)).Select
ContentsSheet.PageSetup.PrintArea = Selection.Address

GoTo Restore

'Error Handling
'==============
ErrorHandler:

If Errloc = -1 Then
    Call HelpMessage(2, 1, 1, "Contents")
    GoTo EndEnd
Else
    error_msg = MsgBox("An error has occurred and the contents table could not be created." & vbNewLine & vbNewLine & _
    "You will have to create the table manually." & vbNewLine & vbNewLine & _
    "Error code: " & Errloc & ".", vbOKOnly + vbCritical, "Order of Cost Estimate - Create Contents List- Error")
End If

'clear anything created so far
ContentsSheet.Select (True)
ContentsSheet.Range(Cells(7, 1), Cells(6 + sectnum - 1, 3)).Select
Selection.Clear
Selection.RowHeight = ActiveSheet.StandardHeight

'Restore display
'===============

Restore:

ActiveWindow.View = xlNormalView
Range("A1").Select
ContentsSheet.Select (True)
Application.ScreenUpdating = True
Application.StatusBar = False   'relinquishes control of status bar

MacroEnd:

ContentsSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ContentsSheet.Cells(7, 2).Select

EndEnd:

End Sub


Private Sub Set_Footers(control As IRibbonControl)

' Inserts project no. and date into left footer of all visible sheets except cover sheet

On Error GoTo MacroError

errMes = "a"
Sheet2.Visible = True
Sheet2.Activate

'Get Data from cover sheet
'=========================
thisSht = Sheet2.Name
    errMes = "Cannot find named range: ""Report_date"". Please ensure that this is defined on " & thisSht & " sheet."
estDate = ActiveWorkbook.Worksheets(thisSht).Range("Report_date").Value
    errMes = "Cannot find named range: ""Project_ref"". Please ensure that this is defined on " & thisSht & " sheet."
estRef = ActiveWorkbook.Worksheets(thisSht).Range("Project_ref").Value

If IsDate(estDate) = True Then estDate = CStr(estDate)  'if contents of "Report_date" range is a date, converts it to a string for insertion into footer - ensures that dd and mm are right way round

'Set up and load Userform
'========================
UserForm1.TextBox1 = estRef
UserForm1.TextBox2 = estDate

Load UserForm1
UserForm1.Show

If UserForm1.CheckBox1 <> True Then GoTo MacroEnd   'if OK button was not pressed jump to end

'Set data to be put into footers
'===============================
estRef = UserForm1.TextBox1
estDate = UserForm1.TextBox2

'Take control of statusbar
'=========================
Application.DisplayStatusBar = True 'forces statusbar to be displayed
Application.StatusBar = "Updating footers..." 'puts text on status bar

'Fill in Left footer
'===================
For Sht = 1 To ActiveWorkbook.Worksheets.Count
    If ActiveWorkbook.Worksheets(Sht).Name <> thisSht And ActiveWorkbook.Worksheets(Sht).Visible = True Then
        Application.StatusBar = "Updating footers... doing " & ActiveWorkbook.Worksheets(Sht).Name & " sheet."
        With ActiveWorkbook.Worksheets(Sht).PageSetup
            .LeftFooter = "&8" & estRef & " &F" & Chr(10) & "Date: " & estDate & Chr(10) & "Printed: &T &D"
        End With
    End If
Next

'Return statusbar control to Excel and reset statusbar contents
'==============================================================
Application.StatusBar = False   'relinquishes control of status bar

GoTo MacroEnd:

MacroError:

If errMes = "a" Then
    Call HelpMessage(2, 1, 1, "Cover")
    GoTo MacroEnd
Else
    Beep
    msg = MsgBox(errMes, vbCritical + vbOKOnly, "Order of Cost Estimate - Set Footers")
End If

MacroEnd:

Unload UserForm1

End Sub

Sub Preparation(control As IRibbonControl)

'Repositions the cursor to cell A1 in each worksheet
'Nice and neat if the workbook is being saved to be issued by email
'Aligns the second logo to the right margin based on the page width

Dim NumSheets, VisibleState, ProtectionState, srow, scol, x, pa, pacol1, pacol2, patext, rangewidth, picwidth, shapecount, shapeloop

On Error GoTo Error

NumSheets = ActiveWorkbook.Worksheets.Count 'Excludes Charts sheets which do not have cells
For x = NumSheets To 2 Step -1  'Steps backwards to end on the first visible sheet (excludes the very hidden version history sheet)
    VisibleState = 1
    ProtectionState = 1
    If Worksheets(x).Visible = False Then   'If sheet is hidden
        VisibleState = 0                    'sets a marker to indicate sheet was hidden
        Worksheets(x).Visible = True        'make it visible
    End If
    If Worksheets(x).ProtectContents = True Then    'if sheet is protected
        ProtectionState = 0                         'sets a marker to indicate sheet was protected
        Worksheets(x).Protect Contents:=False       'unprotects sheet
    End If
    Worksheets(x).Select
    If ActiveWindow.Split = True Then   'if window is split
        srow = ActiveWindow.SplitRow + 1
        scol = ActiveWindow.SplitColumn + 1
        ActiveSheet.Cells(srow, scol).Activate 'move selected cell to top left one inside split
    End If
    Worksheets(x).ClearArrows              'clears formula auditing arrows
    shapecount = Worksheets(x).Shapes.Count
    If shapecount <> 0 Then
        pa = ActiveSheet.PageSetup.PrintArea    'gets the print area
        If pa = "" Then 'if the print area is not defined, set it to the area of the worksheet down to the last cell
            pa = "$A$1:" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Address
            ActiveSheet.PageSetup.PrintArea = pa
        End If
        pacol1 = Mid(pa, 2, 1)  'gets first column in range
        pacol2 = Mid(pa, WorksheetFunction.Search(":", pa) + 2, 1)  'gets second column in range
        patext = pacol1 & ":" & pacol2
        rangewidth = Worksheets(x).Range(patext).Width  'calculates the width of the page
        For shapeloop = 1 To shapecount
            If Worksheets(x).Shapes(shapeloop).Name = "Picture 2" Then
                picwidth = Worksheets(x).Shapes("Picture 2").Width  'gets width of image
                With Worksheets(x).Shapes("Picture 2")  'positions image
                    .Left = rangewidth - picwidth - 1
                    .Top = 2.25
                End With
            End If
        Next shapeloop
    End If
    Range("A1").Activate                'select A1
    If ActiveWindow.View = xlPageBreakPreview Or ActiveWindow.View = xlPageLayoutView Then
        ActiveWindow.View = xlNormalView
    End If
    
    If VisibleState = 0 Then                'checks hidden status marker
        Worksheets(x).Visible = False       'make sheet hidden again
    End If
    If ProtectionState = 0 Then                'checks protection status marker
        Worksheets(x).Protect Contents:=True 'protects sheet
    End If
Next x

Exit Sub

Error:

Beep

End Sub

Private Sub Show_Hide_Version_History()
'
' Hides or Unhides the version history sheet
'
    If SecretSheet.Visible = xlVeryHidden Then
        SecretSheet.Visible = True
        SecretSheet.Activate
    Else
        SecretSheet.Visible = xlVeryHidden
    End If

End Sub

Private Sub About_dialog(control As IRibbonControl)

Dim template_ver As String
Dim template_author As String

template_ver = SecretSheet.Cells(4, 1).Value & " " & SecretSheet.Cells(4, 2).Value ' don't forget to update version history tab
template_author = "David Cane"

UserForm2.VersionText.Caption = "Version: " & template_ver
UserForm2.AuthorText.Caption = "By " & template_author
Load UserForm2
UserForm2.Show

End Sub

Sub Save_PDF(control As IRibbonControl)
'
'Saves the estimate to a PDF file
'

On Error GoTo ErrorProcedure

'Set Variables
'=============
currentSht = ActiveSheet.Name
cSht = ActiveWorkbook.Worksheets.Count
errorproc = 1
extensionpos = WorksheetFunction.Search(".xl", ActiveWorkbook.Name)
bookname = Left(ActiveWorkbook.Name, extensionpos - 1)
bookpath = ActiveWorkbook.Path
ReDim arraySht(0)

'Check that cover sheet sign-off box has been completed
'======================================================
Application.ScreenUpdating = False  'turn off screenupdating

TabName = Sheet2.Name

errorproc = 2
If ActiveWorkbook.Names("Revision").RefersToRange = "-" Then Range("B68").Value = 0
revnr = ActiveWorkbook.Names("Revision").RefersToRange  'get current revision number
revtable = Mid(ActiveWorkbook.Names("Sign_off_table").Value, 2, Len(ActiveWorkbook.Names("Sign_off_table")) - 1)

errorproc = 3
Worksheets(TabName).Activate
Range(revtable).Select
revestimator = WorksheetFunction.VLookup(revnr, Selection, 2)   'check contents of the estimator, reviewer and date columns in the table
revreviewer = WorksheetFunction.VLookup(revnr, Selection, 4)
revdate = WorksheetFunction.VLookup(revnr, Selection, 6)
Range("B68").Select

errorproc = 4
If revestimator = "" Or revreviewer = "" Or revdate = "" Then   'if one if these is empty
    msg = MsgBox("The estimate sign-off table on the " & TabName & " sheet needs to be completed." _
        & vbNewLine & "Do you want to continue with the creation of the PDF?", _
        vbExclamation + vbYesNo, "Elemental Cost Plan - Create PDF")
    If msg = vbNo Then  'if user decides not to continue goes to end
        GoTo MacroEnd
    End If
End If

'Create an array of sheets to print
'==================================
errorproc = 5
For Sht = 1 To cSht
    If ActiveWorkbook.Worksheets(Sht).Visible = True And Left(ActiveWorkbook.Worksheets(Sht).Name, 1) <> "x" Then
        ReDim Preserve arraySht(UBound(arraySht) + 1)   'makes the array dimension bigger by 1
        arraySht(UBound(arraySht)) = ActiveWorkbook.Worksheets(Sht).Name    'sets the array contents
    End If
Next Sht

'Control display
'================
errorproc = 6
Application.DisplayStatusBar = True 'forces statusbar to be displayed
Application.StatusBar = "Creating PDF of all sheets except those hidden or starting with ""x""..." 'puts text on status bar

'Create PDF
'==========
errorproc = 7
Worksheets(arraySht(1)).Select  'select the first sheet
For SelSht = 2 To UBound(arraySht)      'extends the selection to include each of the other sheets to print
    Worksheets(arraySht(SelSht)).Select (False)
Next SelSht
Worksheets(arraySht(1)).Activate

errorproc = 8
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    bookpath & "" & bookname & ".pdf" _
    , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=True
    
GoTo MacroEnd
    
ErrorProcedure:

If errorproc = 1 Then
    msg = MsgBox("Please save the workbook before trying to create a PDF of it.", vbExclamation, "Elemental Cost Plan - Creat PDF")
ElseIf errorproc = 8 Then
    msg = MsgBox("The PDF file '" & bookname & ".pdf' could not be created." _
        & vbNewLine & vbNewLine & "Close any PDFs with the same name and try again.", _
        vbCritical + vbOKOnly, "Elemental Cost Plan - Create PDF")
Else
    msg = MsgBox("An error occured. Error Code: " & errorproc & "." _
        & vbNewLine & vbNewLine & "Please report to David Cane.", vbCritical + vbOKOnly, "Elemental Cost Plan - Create PDF")
End If
    
MacroEnd:

'Restore previous condition
'==========================
Worksheets(currentSht).Select
Worksheets(currentSht).Activate

Application.ScreenUpdating = True  'turn on screenupdating
Application.StatusBar = False

End Sub

Sub Print_Document(control As IRibbonControl)
'
'Prints the document
'
'On Error GoTo ErrorProcedure

'Set Variables
'=============
currentSht = ActiveSheet.Name
cSht = ActiveWorkbook.Worksheets.Count
ReDim arraySht(0)

'Check that cover sheet sign-off box has been completed
'======================================================
Application.ScreenUpdating = False  'turn off screenupdating

TabName = Sheet2.Name

If ActiveWorkbook.Names("Revision").RefersToRange = "-" Then Range("B68").Value = 0
revnr = ActiveWorkbook.Names("Revision").RefersToRange  'get current revision number
revtable = Mid(ActiveWorkbook.Names("Sign_off_table").Value, 2, Len(ActiveWorkbook.Names("Sign_off_table")) - 1)

Worksheets(TabName).Activate
Range(revtable).Select
revestimator = WorksheetFunction.VLookup(revnr, Selection, 2)   'check contents of the estimator, reviewer and date columns in the table
revreviewer = WorksheetFunction.VLookup(revnr, Selection, 4)
revdate = WorksheetFunction.VLookup(revnr, Selection, 6)
Range("B68").Select

If revestimator = "" Or revreviewer = "" Or revdate = "" Then   'if one if these is empty
    msg = MsgBox("The estimate sign-off table on the " & TabName & " sheet needs to be completed." _
        & vbNewLine & "Do you want to continue with printing?", _
        vbExclamation + vbYesNo, "Elemental Cost Plan - Print")
    If msg = vbNo Then  'if user decides not to continue goes to end
        GoTo MacroEnd
    End If
End If

'Create an array of sheets to print
'==================================
For Sht = 1 To cSht
    If ActiveWorkbook.Worksheets(Sht).Visible = True And Left(ActiveWorkbook.Worksheets(Sht).Name, 1) <> "x" Then
        ReDim Preserve arraySht(UBound(arraySht) + 1)   'makes the array dimension bigger by 1
        arraySht(UBound(arraySht)) = ActiveWorkbook.Worksheets(Sht).Name    'sets the array contents
    End If
Next Sht

'Control display
'================
Application.DisplayStatusBar = True 'forces statusbar to be displayed
Application.StatusBar = "Printing all sheets except those hidden or starting with ""x""..." 'puts text on status bar

'Print
'=====
Worksheets(arraySht(1)).Select  'select the first sheet
For SelSht = 2 To UBound(arraySht)      'extends the selection to include each of the other sheets to print
    Worksheets(arraySht(SelSht)).Select (False)
Next SelSht
Worksheets(arraySht(1)).Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
    
GoTo MacroEnd
    
ErrorProcedure:

Beep
    
MacroEnd:

'Restore previous condition
'==========================
Worksheets(currentSht).Select
Worksheets(currentSht).Activate

Application.ScreenUpdating = True  'turn on screenupdating
Application.StatusBar = False

End Sub

Private Sub PDF_Help(control As IRibbonControl)

On Error GoTo ErrorTrap
HelpMessage "A PDF version of the estimate is created automatically" _
    & vbNewLine & "when the Create PDF button is clicked.", "Create PDF", 0, 0
    
GoTo MacroEnd

ErrorTrap:

Call HelpMessage(2, 1, 1, "Create PDF")

MacroEnd:

End Sub


Sub Rounding_Zero(control As IRibbonControl)

'Applies the rounding formula around the contents of the selected cells if it is a formula or value
'Rounds to zero decimal places

'On Error GoTo Error

    sc = Selection.Count
    i = 0
    For Each cell In Selection
        i = i + 1
        mytext = cell.Value
        If cell.HasFormula = True Then
            origform = cell.Formula
            If Left(origform, 7) = "=ROUND(" Then
                LengthZ = Len(origform)
                For Z = LengthZ To 8 Step -1
                    If Mid(origform, Z, 1) = "," Then
                        commastop = Z
                        Exit For
                    End If
                Next
                trimmed = Mid(origform, 8, commastop - 8)
                newform = "=" & trimmed
                cell.Formula = newform
                origform = newform
            End If
            Length = Len(cell.Formula)
            trimmed = Mid(origform, 2, Length - 1)
            newform = "=Round(" & trimmed & ",0)"
            cell.Formula = newform
        End If
        If cell.HasFormula = False And IsEmpty(cell.Value) = False And WorksheetFunction.IsText(cell.Value) = False Then
            origval = cell.Value
            newform = "=Round(" & origval & ",0)"
            cell.Formula = newform
        End If
    Next
    
Exit Sub

Error:

Beep

End Sub

Sub Rounding_Thousands(control As IRibbonControl)

'Applies the rounding formula around the contents of the selected cells if it is a formula or value
'Rounds to thousands

On Error GoTo Error

    sc = Selection.Count
    i = 0
    For Each cell In Selection
        i = i + 1
        mytext = cell.Value
        If cell.HasFormula = True Then
            origform = cell.Formula
            If Left(origform, 7) = "=ROUND(" Then
                LengthZ = Len(origform)
                For Z = LengthZ To 8 Step -1
                    If Mid(origform, Z, 1) = "," Then
                        commastop = Z
                        Exit For
                    End If
                Next
                trimmed = Mid(origform, 8, commastop - 8)
                newform = "=" & trimmed
                cell.Formula = newform
                origform = newform
            End If
            Length = Len(cell.Formula)
            trimmed = Mid(origform, 2, Length - 1)
            newform = "=Round(" & trimmed & ",-3)"
            cell.Formula = newform
        End If
        If cell.HasFormula = False And IsEmpty(cell.Value) = False And WorksheetFunction.IsText(cell.Value) = False Then
            origval = cell.Value
            newform = "=Round(" & origval & ",-3)"
            cell.Formula = newform
        End If
    Next

Exit Sub

Error:

Beep

End Sub

Sub Rounding_2_Dec_Pl(control As IRibbonControl)

'Applies the rounding formula around the contents of the selected cells if it is a formula or value
'Rounds to two decimal places

On Error GoTo Error

    sc = Selection.Count
    i = 0
    For Each cell In Selection
        i = i + 1
        mytext = cell.Value
        If cell.HasFormula = True Then
            origform = cell.Formula
            If Left(origform, 7) = "=ROUND(" Then
                LengthZ = Len(origform)
                For Z = LengthZ To 8 Step -1
                    If Mid(origform, Z, 1) = "," Then
                        commastop = Z
                        Exit For
                    End If
                Next
                trimmed = Mid(origform, 8, commastop - 8)
                newform = "=" & trimmed
                cell.Formula = newform
                origform = newform
            End If
            Length = Len(cell.Formula)
            trimmed = Mid(origform, 2, Length - 1)
            newform = "=Round(" & trimmed & ",2)"
            cell.Formula = newform
        End If
        If cell.HasFormula = False And IsEmpty(cell.Value) = False And WorksheetFunction.IsText(cell.Value) = False Then
            origval = cell.Value
            newform = "=Round(" & origval & ",2)"
            cell.Formula = newform
        End If
    Next

Exit Sub

Error:

Beep

End Sub

Sub UnRound(control As IRibbonControl)

'Removes rounding from formulas

On Error GoTo Error

    sc = Selection.Count
    i = 0
    For Each cell In Selection
        i = i + 1
        mytext = cell.Value
        If cell.HasFormula = True Then
            origform = cell.Formula
            If Left(origform, 7) = "=ROUND(" Then
                Length = Len(origform)
                For Z = Length To 8 Step -1
                    If Mid(origform, Z, 1) = "," Then
                        commastop = Z
                        Exit For
                    End If
                Next
                trimmed = Mid(origform, 8, commastop - 8)
                newform = "=" & trimmed
                cell.Formula = newform
            End If
        End If
    Next

Exit Sub

Error:

Beep

End Sub

Sub Estimate_Choice(control As IRibbonControl)

'Allows user to choose between the detailed level 3 estimate template, the simplified level 2 estimate template
'or the very simplified level 1 estimate

'Set up and load Userform
'========================

On Error GoTo Error

Application.ScreenUpdating = False  'turn off screenupdating

If SecretSheet.Range("F1").Value = "Full" Then  'if the type of estimate is full
    UserForm3.OptionButton1 = True
ElseIf SecretSheet.Range("F1").Value = "Simplified" Then 'if the type of estimate is simplified
    UserForm3.OptionButton2 = True
Else                                                                'if the type of estimate is very simplified
    UserForm3.OptionButton3 = True
End If

SecretSheet.Range("F5").Value = "No"
Load UserForm3
UserForm3.Show

If SecretSheet.Range("F5").Value = "No" Then
    Call Create_Contents_Action(0)
End If

'Select estimate or simplified estimate sheet as appropriate
'===========================================================

If SecretSheet.Range("F1").Value = "Simplified" Then
    Worksheets("Simplified Estimate").Select
ElseIf SecretSheet.Range("F1").Value = "Very Simplified" Then
    Worksheets("Very Simplified Estimate").Select
Else
    Worksheets("Estimate").Select
End If

Application.ScreenUpdating = True  'turn on screenupdating

Exit Sub

Error:

msg = MsgBox("An error has occurred. Check that the Estimate, Simplified Estimate and Very Simplified Estimate sheets are contained " _
    & "in the workbook. Two of them should be hidden." _
    & vbNewLine & vbNewLine & "If one or more is missing you will need to start again or copy a blank version from " _
    & "another copy of the template.", vbCritical + vbOKOnly, "Elemental Cost Plan - Estimate Choice")
End Sub

Sub Set_Address_Box()
'
' Set the Address box on the cover page based on the job number set by the user
' Called by the Worksheet_Change declaration on the Cover Sheet

Application.ScreenUpdating = False

Office_Code = UCase(Left(Range("Job_No").Value, 1))
Select Case Office_Code
Case "L"  'A London project
    BoxName = "Lon_Box"
Case "S"  'A Winchester project
    BoxName = "Win_Box"
Case "B"  'A Birmingham project
    BoxName = "Bir_Box"
Case "R"  'A Southend project
    BoxName = "Sou_Box"
Case Else   'An Orpington project or anything else (such as the default "A" example in the Job Number Box)
    BoxName = "Orp_Box"
End Select

'On Error Resume Next
'ActiveSheet.Shapes.Range(Array("Address_Box")).Delete   'delete existing address box

Call Show_Hide_Version_History  'unhide "very hidden" version history sheet
Sheets("Version History").Select
Sheets("Version History").Shapes.Range(Array(BoxName)).Select   'select one of the boxes based on the Select Case choice
Selection.Copy
Call Show_Hide_Version_History  'hide "very hidden" version history sheet
Sheets("Cover").Select
ActiveSheet.Paste
With Selection  'position and name the new address box
    .ShapeRange.Left = 0
    .ShapeRange.Top = 669
    .Name = "Address_Box"
End With

ActiveCell.Select   'return to the active ceill
Application.ScreenUpdating = True

End Sub

Sub Row_Height_Adjust_Grow(control As IRibbonControl)

'Adjusts height of rows to multiples of the standard height - increases the number
'Will only work on multiple rows if they are the same height already

On Error GoTo Error

rh_default = ActiveSheet.StandardHeight  'get standard height of rows in the work sheet

rh_current = Selection.RowHeight
rh_lines = Int(rh_current / rh_default) 'finds what the nearest whole multiple of current row height is
Selection.RowHeight = (rh_lines + 1) * rh_default

Exit Sub

Error:

Beep

End Sub

Sub Row_Height_Adjust_Shrink(control As IRibbonControl)

'Adjusts height of rows to multiples of the standard height - decreases the number
'Will only work on multiple rows if they are the same height already

On Error GoTo Error

rh_default = ActiveSheet.StandardHeight  'get standard height of rows in the work sheet

rh_current = Selection.RowHeight
rh_lines = Int(rh_current / rh_default) 'finds what the nearest whole multiple of current row height is
If rh_lines > 1 Then    'stops row height being reduced below 1 row
    Selection.RowHeight = (rh_lines - 1) * rh_default
End If

Exit Sub

Error:

Beep

End Sub

Sub Row_Height_Adjust_Reset(control As IRibbonControl)

'Adjusts height of rows to the standard height
'Will only work on multiple rows if they are the same height already

On Error GoTo Error

rh_default = ActiveSheet.StandardHeight  'get standard height of rows in the work sheet
Selection.RowHeight = rh_default

Exit Sub

Error:

Beep

End Sub


############################


Thanking you in advance.

Regards
Sue
 
Last edited by a moderator:
Upvote 0
Again:
What does the error message say?

Hi Dante

There are 2 main problems.

When you click on the "Create Contents" button it asks for the password - this shouldn't happen.

Then when you enter the password the following error appears:

Run-time error '1004':
The cell or chart you are trying to change is on a protected sheet.
To make changes, click Unprotect Sheet in the Review tab(you might need a password).


When I click on the Debug button the following line is highlighted under ErrLoc =7.6

"ActiveWorkbook.Worksheets(Sht).Range("A3").Value = sectnum & ". " & tShtname 'revises sheet title with new section
number"

I hope the above makes sense.

Once again thank you for your help and assistance with this problem.

Kind Regards
Sue
 
Upvote 0
The problem is in the "Create_Contents_Action" macro of the book "Maydew House_password abc"

In the code there is no line to unprotect the sheets.
The sheets in the book are protected.
I think it would be best to unprotect the sheets manually, since you have a lot of code to review. That is, in each place of the code where you modify any cell of any sheet, you must unprotect the sheet - modify the cell - protect the sheet again.


You should also remove the lines of code that have the word protect, for example:
ContentsSheet.Protect DrawingObjects: = True, Contents: = False, Scenarios: = True
 
Upvote 0

Forum statistics

Threads
1,213,529
Messages
6,114,155
Members
448,554
Latest member
Gleisner2

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
Back
Top