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
