VBA Script Error - Run Time Error 1004
Results 1 to 9 of 9

Thread: VBA Script Error - Run Time Error 1004
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Oct 2005
    Posts
    19
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default VBA Script Error - Run Time Error 1004

    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

  2. #2
    Board Regular
    Join Date
    Jul 2012
    Location
    Hampshire, UK
    Posts
    4,933
    Post Thanks / Like
    Mentioned
    21 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    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 by dmt32; Jul 18th, 2019 at 11:50 AM.

  3. #3
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,245
    Post Thanks / Like
    Mentioned
    49 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    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.
    Regards Dante Amor

  4. #4
    New Member
    Join Date
    Oct 2005
    Posts
    19
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    Hi Dante

    Thank you for your help with this problem.

    Links to both spreadsheets listed below;

    https://www.dropbox.com/s/r37b9uzp0o...0abc.xlsm?dl=0

    https://www.dropbox.com/s/ckjy7icxqx...0abc.xlsm?dl=0

    Regards

    Sue



    Quote Originally Posted by DanteAmor View Post
    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.

  5. #5
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,245
    Post Thanks / Like
    Mentioned
    49 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    Quote Originally Posted by suet View Post
    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:
    ContentsSheet.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?
    Regards Dante Amor

  6. #6
    New Member
    Join Date
    Oct 2005
    Posts
    19
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    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 Fluff; Jul 22nd, 2019 at 07:13 AM. Reason: Added code tags

  7. #7
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,245
    Post Thanks / Like
    Mentioned
    49 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    Again:
    What does the error message say?
    Regards Dante Amor

  8. #8
    New Member
    Join Date
    Oct 2005
    Posts
    19
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    Quote Originally Posted by DanteAmor View Post
    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

  9. #9
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    5,245
    Post Thanks / Like
    Mentioned
    49 Post(s)
    Tagged
    14 Thread(s)

    Default Re: VBA Script Error - Run Time Error 1004

    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
    Regards Dante Amor

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •