Option Explicit Option Private Module ' makes function invisible to Excel user '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' ProInsurance (Excel) ' Copyright Jan Iwanik 2014-2016. All rights reserved. Unauthorised copying is prohibited. ' ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ' SOFTWARE. ' ' Under no circumstances can the software be considered a deliverable of any ' contract for services between you and Iwanik Ltd. The software is a separate ' proprietary tool developed and used by Iwanik Ltd. You should delete any ' copies of the software if your contract for services with Iwanik Ltd has finished. ' You must not decrypt or remove access protection from this software. ' The software is provided 'as is' and we take not responsibility for the results of ' your work if it is completed using this software. ' ' The above copyright notice and this permission notice shall be included in all ' copies or substantial portions of the Software. ' ' ' Must be saved as module "proInsurance". ' Version control (DELETE FROM RELEASE VERSION) ' ' v1.32 - added Impact Express ' v1.26 - old ln() trend for premiums and burning cost in loss ratio indications did not give nice predictions in each UW year. ' So replaced with linear trend. Then changed estimated % increase to calculate the percentage from the total slope over ' the period, so that it is still multiplicative. ' v1.27 - check before overwriting CSV files. Also, for Carver change the way conditions are copied (instead of dragged) ' v1.35 - split into modules ' v1.70 - added classifier ' v1.86 - licence added to installation ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' LINKING PUBLIC FUNCTIONS ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Sub link_functions() Dim this_name As String this_name = ActiveSheet.name If sheetExists("Functions") = False Then Call addSheet("Functions") Sheets("Functions").Activate Range("A1").Value = "Public functions" Range("A2").Value = "Can be used in any context" Call set_style("A1", "bold") Call set_style("A2", "italic") Call fontReset("Functions") Range("B5").Value = "Function name" Range("C5").Value = "Example" Range("B6").Value = "band" Range("C6").Formula = "=band(1.234656, 0.5, 0, 10, ""up"")" Range("B7").Value = "band123102030" Range("C7").Formula = "=band123102030(1345,""up"")" Range("B8").Value = "band110100" Range("C8").Formula = "=band123102030(54323,""down"")" Range("B9").Value = "band125102050" Range("C9").Formula = "=band125102050(423,""up"")" Range("B10").Value = "bandLOOKUP" Range("C10").Formula = "=bandLOOKUP(1.5,H6:H9,""up"")" Range("B11").Value = "interpolate" Range("C11").Value = "=interpolate(18,G6:G9,H6:H9)" Range("B12").Value = "get_date" Range("C12").Formula = "=get_date(""4/1/1962"", ""mm/dd/yyyy"")" Range("B13").Value = "get_dateSerial" Range("C13").Formula = "=get_dateSerial(C16, ""yyyymmdd"")" Range("B14").Value = "PoissonInvCDF" Range("C14").Formula = "=PoissonInvCDF(0.95, 2)" Range("B15").Value = "PoissonRand" Range("C15").Formula = "=PoissonRand(2)" Range("B16").Value = "NegBinomPDF" Range("C16").Formula = "=NegBinomPDF(7, 10, 2)" Range("B17").Value = "NegBinomInvCDF" Range("C17").Formula = "=NegBinomInvCDF(0.95, 10, 2)" Range("B18").Value = "NegBinomRand" Range("C18").Formula = "=NegBinomRand(10, 2)" Range("B19").Value = "LognormCDF" Range("C19").Formula = "=LognormCDF(1500000, 11, 2)" Range("B20").Value = "LognormInvCDF" Range("C20").Formula = "=LognormInvCDF(c20,11,2)" Range("B21").Value = "LognormCappedEX" Range("C21").Formula = "=LognormCappedEX(100000, 11,2)" Range("B22").Value = "GeneralizedParetoCDF" Range("C22").Formula = "=GeneralizedParetoCDF(17500000, 5000000, 5100000, 0.7)" Range("B23").Value = "GeneralizedParetoInvCDF" Range("C23").Formula = "=GeneralizedParetoInvCDF(0.95, 5000000, 5100000, 0.7)" Range("B24").Value = "LognormWithGPDTailCondAboveCDF" Range("C24").Formula = "=LognormWithGPDTailCondAboveCDF(1250000, 1000, 11, 2, 0.01, 5000000, 5100000, 0.7)" Range("B25").Value = "LognormWithGPDTailCondAboveInvCDF" Range("C25").Formula = "=LognormWithGPDTailCondAboveInvCDF(0.95, 1000, 11, 2, 0.01, 5000000, 5100000, 0.7)" Range("B26").Value = "LognormWithGPDTailCondAboveCappedEX" Range("C26").Formula = "=LognormWithGPDTailCondAboveCappedEX(20000000, 1000, 11, 2, 0.01, 5000000, 5100000, 0.7)" Range("B27").Value = "MbbefdCDF" Range("C27").Formula = "=MbbefdCDF(0.5, Exp(3.1 - 0.15 * (1 + 3) * 3), Exp((0.78 + 0.12 * 3) * 3))" Range("B28").Value = "MbbefdInvCDF" Range("C28").Formula = "=MbbefdInvCDF(c28, Exp(3.1 - 0.15 * (1 + 3) * 3), Exp((0.78 + 0.12 * 3) * 3))" Range("B29").Value = "MbbefdG" Range("C29").Formula = "=MbbefdG(61%,0.1,22)" Range("B30").Value = "MbbefdGc" Range("C30").Formula = "=MbbefdGc(41%,4)" ' Range("B15").Value = "invCondLognormGPD" ' Range("C15").Formula = "=invCondLognormGPD(0.5, 5000,11.18,2.16, 0.027,5e6,12150682,0.7154)" Range("G6").Value = 10 Range("G7").Value = 20 Range("G8").Value = 30 Range("G9").Value = 40 Range("H6").Value = 1.2 Range("H7").Value = 2.7 Range("H8").Value = 3.9 Range("H9").Value = 5.8 Call set_style("B5:C5", "header") Call set_style("G6:H9", "grey") Columns("B:B").ColumnWidth = 16 Call fontReset("Functions") Range("A1").Select Sheets(this_name).Activate ''' FIND occurances for add-in name and remove it, this is fixing silly Excel behaviour Dim found_cell As Range Dim ws As Worksheet Dim ind As Integer, ind_1 As Integer, ind_2 As Integer, I As Integer Dim template_str As String Application.Calculation = xlManual For Each ws In ActiveWorkbook.Worksheets On Error Resume Next Cells.Find(what:="proInsurance.xlam", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate ind = InStr(ActiveCell.Formula, "proInsurance.xlam") If ind > 0 Then For I = ind To Len(ActiveCell.Formula) If Mid(ActiveCell.Formula, I, 1) = "!" Then ind_2 = I: I = Len(ActiveCell.Formula) Next For I = 1 To ind - 1 If Mid(ActiveCell.Formula, ind - I, 1) = "'" Then ind_1 = ind - I I = ind ElseIf Mid(ActiveCell.Formula, ind - I, 1) = "=" Then ind_1 = ind - I I = ind End If Next template_str = Mid(ActiveCell.Formula, ind_1, ind_2 - ind_1 + 1) Cells.Replace what:=template_str, replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _ SearchFormat:=False, ReplaceFormat:=False End If Range("A1").Select Next Sheets(this_name).Activate Application.Calculation = xlAutomatic Range("A1").Select End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''' A B O U T '''''' A B O U T ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function getLicen(infotype As String) As String getLicen = "1. You can use this software only under our written permission." & _ vbNewLine & "2. This software might make errors. It is your responsibility to decide that you accept this risk." & _ " The author is not liable for any damage of any kind which can be linked to your use of this software. " & _ vbNewLine & "3. No intelectual property rights to this software are transfered to you whatsoever." & _ vbNewLine & "4. You can not decompile or otherwise attempt to hack this software." & _ vbNewLine & "5. Under no circumstances can the software be considered a deliverable of any " & _ "contract for services between you and us. The software is a separate " & _ "proprietary tool developed and used by Jan Iwanik." & _ vbNewLine & _ vbNewLine & "THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR " & _ "IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, " & _ "FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE " & _ "AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER " & _ "LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, " & _ "OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE " & _ "SOFTWARE.)" Dim getLicen2 As String, getLicen3 As String, getLicen4 As String getLicen2 = "Software License Agreement" & vbNewLine & vbNewLine & _ "Between: You (the Licensee) and Jan Iwanik (the Licensor) " & vbNewLine & _ "Named Software: actuarial tools available from Code Repository on www.iwanik.co.uk, " & _ "including, but not limited to ProInsurance (Excel), Carver, ProInsurance (Access), SA S" & _ "macros, Triangle Classification, Impact Express, Optimisation Express, MBBEFD Curves." & vbNewLine & vbNewLine & _ "1. This is an agreement between Licensor and Licensee, who is being licensed to use the named Software." & vbNewLine & _ "2. Licensee acknowledges that this is only a limited nonexclusive license. Licensor is and remains the " & _ "owner of all titles, rights, and interests in the Software." & vbNewLine & _ "3. This License permits Licensee to install the Software on more than one computer system, as long as " & _ "the Software will not be used on more than one computer system simultaneously. Licensee will not make " & _ "copies of the Software or allow copies of the Software to be made by others, unless authorized by this " & _ "License Agreement. Licensee may make copies of the Software for backup purposes only." & vbNewLine & _ "4. This Software is subject to a limited warranty. Licensor warrants to Licensee that the " & _ "physical medium on which this Software is distributed is free from defects in materials and " & _ "workmanship under normal use, the Software will perform according to its printed " & _ "documentation, and to the best of Licensor's knowledge Licensee's use of this Software " & _ "according to the printed documentation is not an infringement of any third party's intellectual " & _ "property rights. This limited warranty lasts for a period of 10 days after delivery. To the " & _ "extent permitted by law, " getLicen3 = "THE ABOVE-STATED LIMITED WARRANTY REPLACES ALL " & _ "OTHER WARRANTIES, EXPRESS OR IMPLIED, AND LICENSOR DISCLAIMS ALL " & _ "IMPLIED WARRANTIES INCLUDING ANY IMPLIED WARRANTY OF TITLE," & _ "MERCHANTABILITY, NONINFRINGEMENT, OR OF FITNESS FOR A PARTICULAR" & _ "PURPOSE. No agent of Licensor is authorized to make any other warranties or to modify this" & _ "limited warranty. Any action for breach of this limited warranty must be commenced within" & _ "one year of the expiration of the warranty. Because some jurisdictions do not allow any limit" & _ "on the length of an implied warranty, the above limitation may not apply to this Licensee. If " & _ "the law does not allow disclaimer of implied warranties, then any implied warranty is limited " & _ "to 10 days after delivery of the Software to Licensee. Licensee has specific legal rights " & _ "pursuant to this warranty and, depending on Licensee's jurisdiction, may have additional " & _ "rights. " & vbNewLine & _ "5. In case of a breach of the Limited Warranty, Licensee's exclusive remedy is as follows: " & _ "Licensee will return all copies of the Software to Licensor, at Licensee's cost, along with " & _ "proof of purchase. (Licensee can obtain a step-by-step explanation of this procedure, " & _ "including a return authorization code, by contacting Licensor.) " & _ "At Licensor's option, Licensor will either send Licensee a replacement " & _ "copy of the Software, at Licensor's expense, or issue a full refund." & vbNewLine getLicen4 = "6. Notwithstanding the foregoing, LICENSOR IS NOT LIABLE TO LICENSEE FOR ANY " & _ "DAMAGES, INCLUDING COMPENSATORY, SPECIAL, INCIDENTAL, EXEMPLARY, " & _ "PUNITIVE, OR CONSEQUENTIAL DAMAGES, CONNECTED WITH OR RESULTING " & _ "FROM THIS LICENSE AGREEMENT OR LICENSEE'S USE OF THIS SOFTWARE. " & _ "Licensee 's jurisdiction may not allow such a limitation of damages, so this limitation may not apply. " & vbNewLine & _ "7. Licensee agrees to defend and indemnify Licensor and hold Licensor harmless from all " & _ "claims, losses, damages, complaints, or expenses connected with or resulting from Licensee's business operations." & vbNewLine & _ "8. Licensor has the right to terminate this License Agreement and Licensee's right to use this " & _ "Software upon any material breach by Licensee. " & vbNewLine & _ "9. Licensee agrees to return to Licensor or to destroy all copies of the Software upon termination of the License." & vbNewLine & _ "10. This License Agreement is the entire and exclusive agreement between Licensor and " & _ "Licensee regarding this Software. This License Agreement replaces and supersedes all prior " & _ "negotiations, dealings, and agreements between Licensor and Licensee regarding this Software." & vbNewLine & _ "11. This License Agreement is governed by the law of England and Wales applicable to all contracts." & vbNewLine & _ "12. This License Agreement is valid without Licensor's signature. It becomes effective upon " & _ "the earlier of Licensee's signature or Licensee's use of the Software." & vbNewLine & _ "13. This License terminates at the end of year 2019 and the Licensee has no rights to use the Software afterwards." If infotype = "long" Then getLicen = getLicen2 & getLicen3 & getLicen4 End Function Public Sub about_pro() MsgBox ("ProInsurance (Excel) v2.54. Copyright Jan Iwanik 2012-2020." & _ vbNewLine & _ vbNewLine & "Licence Agreement (shortened):" & vbNewLine & getLicen("short")) End Sub 'Loop through all the hidden names in the active 'work book Public Sub removeHiddenNames() Dim xName As name, inspect As String Dim f As String For Each xName In ActiveWorkbook.Names If xName.Visible = False Then inspect = xName.name xName.Delete End If Next Set xName = Nothing End Sub ' adds multiplicative regression ' linear or logarithmic at the moment ' pass cell addresses as strings Public Sub addRegressionMaths(range_x As String, range_y As String, _ range_weight1 As String, range_weight2 As String, _ out_headers As String, out_values As String, _ predict_into As String, linear As Boolean) Dim inx As Range Dim outh As Range Dim outv As Range Dim pred As Range Set inx = Range(range_x) Set outh = Range(out_headers) Set outv = Range(out_values) Set pred = Range(predict_into) Dim tran As String Dim range_w_comma As String, range_w_sum As String, range_w_multi As String tran = "ln" If linear = True Then tran = "" If range_weight1 <> "" Then range_w_comma = range_weight1 If range_weight2 <> "" Then range_w_comma = range_w_comma & "," & range_weight2 range_w_sum = "sumproduct(" & range_w_comma & ")" If range_weight1 <> "" Then range_w_comma = "," & range_w_comma If range_weight1 = "" Then range_w_sum = Range(range_x).Cells.Count range_w_multi = "*" & range_weight1 If range_weight2 <> "" Then range_w_multi = range_w_multi & "*" & range_weight2 If range_weight1 = "" Then range_w_multi = "" outh.Cells(1).Value = "mean X" outv.Cells(1).Formula = "=sumproduct(" & range_x & range_w_comma & ")/" & range_w_sum outh.Cells(2).Value = "mean Y" outv.Cells(2).Formula = "=sumproduct(" & tran & "(" & range_y & ")" & range_w_comma & ")/" & range_w_sum outh.Cells(3).Value = "prod XY" outv.Cells(3).FormulaArray = "=sum((" & range_x & "-" & outv(1).address & ")*(" & tran & "(" & range_y & ")-" & outv(2).address & ")" & range_w_multi & ")/" & range_w_sum outh.Cells(4).Value = "prod XX" outv.Cells(4).FormulaArray = "=sum((" & range_x & "-" & outv(1).address & ")*(" & range_x & "-" & outv(1).address & ")" & range_w_multi & ")/" & range_w_sum outh.Cells(5).Value = "b" outv.Cells(5).Formula = "=" & outv.Cells(3).address & "/" & outv.Cells(4).address outh.Cells(6).Value = "a" outv.Cells(6).Formula = "=" & outv.Cells(2).address & "-" & outv.Cells(5).address & "*" & outv.Cells(1).address Dim I As Long For I = 1 To inx.Cells.Count If linear = True Then pred.Cells(I).Formula = "=" & inx.Cells(I).address & "*" & outv.Cells(5).address & "+" & outv.Cells(6).address If linear = False Then pred.Cells(I).Formula = "=exp(" & inx.Cells(I).address & "*" & outv.Cells(5).address & "+" & outv.Cells(6).address & ")" Next I Dim r2formula As String, r2formula_num As String outh.Cells(7).Value = "R^2 num" r2formula_num = "sum((" & range_y & "-" & predict_into & ")*(" & range_y & "-" & predict_into & ")" & range_w_multi & ")" outv.Cells(7).FormulaArray = "=" & r2formula_num outh.Cells(8).Value = "R^2" If linear = True Then r2formula = "1-" & outv.Cells(7).address & "/ sum((" & range_y & "-" & outv(2).address & ")*(" & range_y & "-" & outv(2).address & ")" & range_w_multi & ")" If linear = False Then r2formula = "1-" & outv.Cells(7).address & "/ sum((" & range_y & "-exp(" & outv(2).address & "))*(" & range_y & "-exp(" & outv(2).address & "))" & range_w_multi & ")" outv.Cells(8).Value = r2formula outv.Cells(8).FormulaArray = "=" & r2formula ''Range("P1").FormulaArray = "=1 -sum((C25:E25-C27:E27)*(C25:E25-C27:E27)*C18:E18*C11:E11)/ sum(C11:E11*(C25:E25-$R$27)*(C25:E25-$R$27)*C18:E18)" End Sub ' gets a column letter from column number -- up to ZZ Public Function getColLetter(col As Long) As String If col <= 26 Then ' Columns A-Z getColLetter = Chr(col + 64) Else getColLetter = getColLetter(Int((col - 1) / 26)) & getColLetter(((col - 1) Mod 26) + 1) End If End Function Public Function getMaxSheetRows() As Long getMaxSheetRows = ActiveWorkbook.Sheets(1).rows.Count End Function Public Function getMaxSheetCols() As String getMaxSheetCols = "XFD" If getMaxSheetRows() = 65536 Then getMaxSheetCols = "IV" End Function ' ' Gets a column number from column number Public Function getColNumber(col As String) As Integer Dim StringLength As Integer, I As Integer Dim Count As Long Dim Letter As String StringLength = Len(col) For I = 1 To StringLength Letter = Asc(Mid(col, I, 1)) If I > 1 Then Count = Count + ((Letter - 64) * (I - 1) * 26) - 1 getColNumber = 26 * getColNumber + Letter - 64 Next I End Function ' ' Finds the last row in a sheet Public Function get_lastRow(Optional in_sheet As String = "") As Long If in_sheet = "" Then get_lastRow = ActiveSheet.UsedRange.rows(ActiveSheet.UsedRange.rows.Count).row If in_sheet <> "" Then get_lastRow = Sheets(in_sheet).UsedRange.rows(Sheets(in_sheet).UsedRange.rows.Count).row End Function Public Function get_lastCol() As Long get_lastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).column End Function ' ' Gets a row number ' blank row means its the end Public Function count_rows_from(col As String, row As Integer) As Long count_rows_from = 0 While Range(col & count_rows_from + row).Value <> "" count_rows_from = count_rows_from + 1 Wend End Function ' ' Gets a column number from column number ' blank row means its the end Public Function count_cols_from(col As String, row As Integer) As Integer count_cols_from = 0 Dim col_number As Long col_number = getColNumber(col) While Cells(row, col_number + count_cols_from).Value <> "" count_cols_from = count_cols_from + 1 Wend End Function ' ' Gets wheather license is valid Public Function licence() licence = False If Year(Now()) <= 2020 Then licence = True End Function ' ' check if a sheet exists Public Function sheetExists(this_sheet As String) As Boolean sheetExists = False Dim isheet As Worksheet For Each isheet In Worksheets If this_sheet = isheet.name Then sheetExists = True Exit Function End If Next isheet End Function ' creates a sheet if needed Public Sub addSheet(sheet_name) Dim wstest As Worksheet ' add sheet if it does not exist Set wstest = Nothing On Error Resume Next Set wstest = ActiveWorkbook.Worksheets(sheet_name) On Error GoTo 0 If wstest Is Nothing Then Worksheets.Add.name = sheet_name End If End Sub ' renames sheet (and deletes old if needed) Public Sub renameSheet(new_name As String) Dim this_sheet As String this_sheet = ActiveSheet.name If sheetExists(new_name) And new_name <> this_sheet Then Application.DisplayAlerts = False Sheets(new_name).Delete Application.DisplayAlerts = True End If ActiveSheet.name = new_name End Sub ' delete chart Public Sub deleteChart(Optional chart_name As String = "") Dim this_sheet As String, this_chart As String Dim r_count As Long this_sheet = ActiveSheet.name this_chart = chart_name If chart_name = "" Then this_chart = "carver_" & this_sheet r_count = count_rows_from("A", 7) ' delete chart if it is there On Error Resume Next Dim CurrentChart As Variant Set CurrentChart = ActiveSheet.ChartObjects(this_chart) On Error GoTo 0 If IsEmpty(CurrentChart) = False Then CurrentChart.Activate ActiveChart.Parent.Delete End If End Sub ' clears sheet - it must exist Public Sub clearSheet(sheet_name, from_row) Sheets(sheet_name).Activate Range("A" & from_row & ":" & getMaxSheetCols() & getMaxSheetRows()).Select Selection.Delete Shift:=xlUp End Sub ' Sets default font size Public Sub fontReset(sheet_name) Sheets(sheet_name).Select Cells.Select With Selection.Font .name = "Calibri" .size = 9 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .TintAndShade = 0 .ThemeFont = xlThemeFontMinor End With Cells.Select Range("A1").Activate Cells.EntireRow.AutoFit Range("A1").Select End Sub Public Sub set_style(address, style) Range(address).Select If style = "normal" Then With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 End With With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone Selection.Borders(xlEdgeLeft).LineStyle = xlNone Selection.Borders(xlEdgeTop).LineStyle = xlNone Selection.Borders(xlEdgeBottom).LineStyle = xlNone Selection.Borders(xlEdgeRight).LineStyle = xlNone Selection.Borders(xlInsideVertical).LineStyle = xlNone Selection.Borders(xlInsideHorizontal).LineStyle = xlNone End If If style = "comma" Then Selection.style = "Comma" Selection.NumberFormat = "_-* #,##0.0_-;-* #,##0.0_-;_-* ""-""??_-;_-@_-" Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-" Selection.NumberFormat = "_-* #,##0.00_-;-* #,##0.00_-;_-* ""-""??_-;_-@_-" End If If style = "general" Then Selection.NumberFormat = "General" End If If style = "integer" Then Selection.style = "Comma" Selection.NumberFormat = "_-* #,##0.0_-;-* #,##0.0_-;_-* ""-""??_-;_-@_-" Selection.NumberFormat = "_-* #,##0_-;-* #,##0_-;_-* ""-""??_-;_-@_-" End If If style = "0000" Then Selection.style = "Comma" Selection.NumberFormat = "_-* #,##0.000_-;-* #,##0.000_-;_-* ""-""??_-;_-@_-" Selection.NumberFormat = "_-* #,##0.0000_-;-* #,##0.0000_-;_-* ""-""??_-;_-@_-" End If If style = "date" Then Application.CutCopyMode = False Selection.NumberFormat = "yyyy-mm-dd;@" End If If style = "green" Then Application.CutCopyMode = False With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 5287936 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If style = "red" Then Application.CutCopyMode = False With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 255 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If style = "redfont" Then Application.CutCopyMode = False With Selection.Font .Color = -16776961 .TintAndShade = 0 End With End If If style = "grey" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.149998474074526 .PatternTintAndShade = 0 End With End If If style = "wrap" Then With Selection .VerticalAlignment = xlTop .WrapText = True End With End If If style = "black" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If If style = "fading" Then With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = -4.99893185216834E-02 End With End If If style = "blue-white" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 12611584 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If If style = "dark-blue-white" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 6299648 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If If style = "red-white" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 2689232 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With End If If style = "header" Or style = "headernowrap" Then With Selection.Font .Color = -16711681 .TintAndShade = 0 End With With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If style = "vertical" Then With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlBottom .WrapText = True .Orientation = -90 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With End If If style = "light-green" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.599993896298105 .PatternTintAndShade = 0 End With End If If style = "light-grey" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -4.99893185216834E-02 .PatternTintAndShade = 0 End With End If If style = "pink" Then With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 16764159 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If If style = "header" Or style = "header" Then With Selection .WrapText = True End With End If If style = "percent" Then Selection.style = "Percent" Selection.NumberFormat = "0.0%" End If If style = "percentfull" Then Selection.style = "Percent" Selection.NumberFormat = "0%" End If If style = "input" Then Call set_style(address, "normal") With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent1 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With End If If style = "italic" Then Selection.Font.Italic = True End If If style = "bold" Then Selection.Font.Bold = True End If If style = "rainbow" Then Selection.FormatConditions.AddColorScale ColorScaleType:=3 Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority Selection.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor .Color = 8109667 .TintAndShade = 0 End With Selection.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50 With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor .Color = 8711167 .TintAndShade = 0 End With Selection.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor .Color = 7039480 .TintAndShade = 0 End With End If If style = "merge" Then With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Selection.Merge With Selection .HorizontalAlignment = xlLeft .VerticalAlignment = xlTop .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = True End With End If If style = "borders" Then Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With End If If style = "bborders" Then Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With End If If style = "bborders-top" Then Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With End If If style = "bborders-bottom" Then Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlMedium End With End If If style = "center" Then With Selection .HorizontalAlignment = xlCenter End With End If If style = "horiz-borders" Then Selection.Borders(xlInsideVertical).LineStyle = xlNone With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With End If If style = "verylight" Then With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = -4.99893185216834E-02 End With End If End Sub Public Sub set_style_chart() ActiveChart.PlotArea.Select With Selection.Format.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.0500000007 .Transparency = 0 .Solid End With End Sub Public Sub set_validation(where As String, list As String) Range(where).Select With Selection.Validation .Delete End With If list = "" Then Exit Sub With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=list .IgnoreBlank = False .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End Sub ' make a standard line-column chart dor showing exposure and lines ' ranges must include sheet name ! Public Sub column_line_chart_make(chart_name As String, chart_title As String, _ range_x As String, _ name_y_col As String, range_y_col As String, _ name_y_line As String, range_y_line As String, _ topleft As String, bottomright As String) Call deleteChart(chart_name) Range(range_y_col).Select ActiveSheet.Shapes.AddChart.Select ActiveChart.ChartType = xlColumnClustered ActiveChart.SetSourceData Source:=Range(range_y_col) ActiveChart.SeriesCollection(1).Values = "=" & range_y_col ActiveChart.SeriesCollection(1).XValues = "=" & range_x ActiveChart.SeriesCollection(1).name = name_y_col ActiveChart.SeriesCollection.NewSeries ActiveChart.SeriesCollection(2).Values = "=" & range_y_line ActiveChart.SeriesCollection(2).XValues = "=" & range_x ActiveChart.SeriesCollection(2).name = name_y_line ActiveChart.SeriesCollection(2).ChartType = xlLine ActiveChart.SeriesCollection(2).AxisGroup = 2 With ActiveChart .Parent.name = chart_name .HasTitle = True .ChartTitle.Select .ChartTitle.Text = chart_title .Parent.Top = Range(topleft).Top .Parent.Left = Range(topleft).Left .Parent.Height = Range(topleft & ":" & bottomright).Height End With Call set_style_chart End Sub ' make a standard chart ' ranges must include sheet name ! Public Sub column_line_chart_add(name_y_line As String, range_y_line As String) Dim sercount As Long sercount = 1 + ActiveChart.SeriesCollection.Count ActiveChart.SeriesCollection.NewSeries ActiveChart.SeriesCollection(sercount).Values = "=" & range_y_line ' ActiveChart.SeriesCollection(2).XValues = "=" & range_x ActiveChart.SeriesCollection(sercount).name = name_y_line ActiveChart.SeriesCollection(sercount).ChartType = xlLine ActiveChart.SeriesCollection(sercount).AxisGroup = 2 End Sub