XL VBA kitchen utils

20220509 1345 

 

KitchenUtils_v20180430.xlsm

0.05MB

(module)      (function)

mBarrier  ⟶ kckcKolb

mBinary  ⟶ kcBOption

mBlack76  ⟶ kcBlack

mBlackScholes  ⟶ kcBlackScholes

mDistribution  ⟶ kcCND, kcCBND

mGreeks  ⟶ kcGreeks

mMatrix  ⟶ kcMat_Cholesky

mSpreadOption  ⟶ kcSpreadOptionPrice

 

mChart  ⟶ kcChangeAxisScales

mUtil

 

Sub zMakeBoxes() Dim shp1 As Shape For i = 1 To Selection.Areas.Count     x1 = Selection.Areas.Item(i).Left     w1 = Selection.Areas.Item(i).Width     y1 = Selection.Areas.Item(i).Top     h1 = Selection.Areas.Item(i).Height     '''add box     Set shp1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x1, y1, w1, h1)     shp1.Fill.Visible = msoFalse 'unfill the interior of boxes Next i End Sub Sub zConnectTwoCells_with_box_and_kinked_line() zx = TypeName(Selection) 'rectangle 'zx = Selection.ShapeRange.ShapeStyle 'zx = Selection.ShapeRange.Type     Dim shp1 As Shape     Dim shp2 As Shape If zx = "Range" Then     x1 = Selection.Areas.Item(1).Left     w1 = Selection.Areas.Item(1).Width     y1 = Selection.Areas.Item(1).Top     h1 = Selection.Areas.Item(1).Height          x2 = Selection.Areas.Item(2).Left     y2 = Selection.Areas.Item(2).Top     w2 = Selection.Areas.Item(2).Width     h2 = Selection.Areas.Item(2).Height     '''add box     Set shp1 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x1, y1, w1, h1)     Set shp2 = ActiveSheet.Shapes.AddShape(msoShapeRectangle, x2, y2, w2, h2)          shp1.Fill.Visible = msoFalse     shp2.Fill.Visible = msoFalse Else     x1 = Selection.ShapeRange.Item(1).Left     w1 = Selection.ShapeRange.Item(1).Width     y1 = Selection.ShapeRange.Item(1).Top     h1 = Selection.ShapeRange.Item(1).Height          x2 = Selection.ShapeRange.Item(2).Left     y2 = Selection.ShapeRange.Item(2).Top     w2 = Selection.ShapeRange.Item(2).Width     h2 = Selection.ShapeRange.Item(2).Height          Set shp1 = Selection.ShapeRange.Item(1)     Set shp2 = Selection.ShapeRange.Item(2) End If Set conn = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, x1, y1, x2, y2) With conn.ConnectorFormat   conn.Line.ForeColor.RGB = RGB(0, 0, 255)   conn.Line.EndArrowheadStyle = msoArrowheadTriangle 'BeginArrowheadStyle   conn.Line.EndArrowheadLength = msoArrowheadLong   .BeginConnect ConnectedShape:=shp1, ConnectionSite:=2 '1=up, 2=left, 3=down, 4= right   .EndConnect ConnectedShape:=shp2, ConnectionSite:=1   conn.RerouteConnections 'optimization End With End Sub Sub zKDBStandardChart()  ActiveChart.Axes(xlValue).MajorGridlines.Select  Selection.Delete    'If Not (ActiveChart.HasLegend) Then    ActiveChart.SetElement (msoElementLegendLeftOverlay)  'End If    ActiveChart.Legend.Select  Selection.Left = 160  Selection.Top = 0    If (ActiveChart.HasTitle) Then   ActiveChart.ChartTitle.Delete  End If    Dim zShape As Object  Set zShape = ActiveSheet.Shapes(ActiveChart.Parent.Name)    zShape.Line.Visible = msoFalse  ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, _              20, 0, Width:=30, Height:=20) _              .TextFrame.Characters.Text = "(%)"      End Sub 'add on 20150723 Sub kcDrawHLine() Dim Obj As Shape L1 = Selection.Cells(1).Left cnt = Selection.Columns.Count L2 = Selection.Cells(cnt).Left + Selection.Cells(cnt).Width 'right T1 = Selection.Cells(1).Top + Selection.Cells(1).Height / 2 Set Obj = ActiveSheet.Shapes.AddLine(L1, T1, L2, T1) With Obj.Line   .Weight = 3   .EndArrowheadStyle = msoArrowheadTriangle   .EndArrowheadLength = msoArrowheadLengthMedium   .EndArrowheadWidth = msoArrowheadWidthMedium End With End Sub Sub kcDrawHLine_reverse() Dim Obj As Shape L1 = Selection.Cells(1).Left cnt = Selection.Columns.Count L2 = Selection.Cells(cnt).Left + Selection.Cells(cnt).Width 'right T1 = Selection.Cells(1).Top + Selection.Cells(1).Height / 2 Set Obj = ActiveSheet.Shapes.AddLine(L2, T1, L1, T1) With Obj.Line   .Weight = 3   .EndArrowheadStyle = msoArrowheadTriangle   .EndArrowheadLength = msoArrowheadLengthMedium   .EndArrowheadWidth = msoArrowheadWidthMedium End With End Sub Sub kcDrawVLine() Dim Obj As Shape x1 = Selection.Cells(1).Left + Selection.Cells(cnt).Width / 2 cnt = Selection.Rows.Count x2 = x1 y1 = Selection.Cells(1).Top y2 = Selection.Cells(cnt).Top + Selection.Cells(cnt).Height 'down Set Obj = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2) With Obj.Line   .Weight = 3   .EndArrowheadStyle = msoArrowheadTriangle   .EndArrowheadLength = msoArrowheadLengthMedium   .EndArrowheadWidth = msoArrowheadWidthMedium End With End Sub Sub kcDrawVLine_reverse() Dim Obj As Shape x1 = Selection.Cells(1).Left + Selection.Cells(cnt).Width / 2 cnt = Selection.Rows.Count x2 = x1 y1 = Selection.Cells(1).Top y2 = Selection.Cells(cnt).Top + Selection.Cells(cnt).Height 'down Set Obj = ActiveSheet.Shapes.AddLine(x2, y2, x1, y1) With Obj.Line   .Weight = 3   .EndArrowheadStyle = msoArrowheadTriangle   .EndArrowheadLength = msoArrowheadLengthMedium   .EndArrowheadWidth = msoArrowheadWidthMedium End With End Sub 'add on 20140626 Function kcFilename2()  ans = ThisWorkbook.Sheets(1).Range("a1")  ans = "'" & ans  kcFilename2 = ans End Function 'add on 20130318 Sub kcPaintFormulaCells() oldStatusBar = Application.DisplayStatusBar Application.DisplayStatusBar = True i = 1 nmbr = ActiveSheet.UsedRange.Rows.Count nmbc = ActiveSheet.UsedRange.Columns.Count Nmb = nmbr * nmbc BoxLine = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight) For Each xRng In ActiveSheet.UsedRange   xRng.Select   If Left(xRng.FormulaLocal, 1) = "=" Then     xRng.Interior.Color = RGB(230, 230, 230)     For iBox = 1 To UBound(BoxLine, 1)       With xRng.Borders(BoxLine(iBox))         .LineStyle = xlContinuous         .ThemeColor = 1       End With     Next iBox   Else     xRng.Interior.Pattern = xlNone   End If   Application.StatusBar = Int(i / Nmb * 100) & "%"   i = i + 1 Next xRng Application.StatusBar = False Application.DisplayStatusBar = oldStatusBar End Sub 'add on 20110720 Sub kcCopyHangYeol()   UserForm2.Show End Sub Sub Macro1(Nmb As Integer) If Nmb = 1 Then Dim oRg As Range, tRg As Range Dim xString As String Dim nmbRow As Integer, nmbCol As Integer xString = UserForm2.RefEdit1.Value Set oRg = Range(xString) '.Rows.Count nmbRow = oRg.Rows.Count nmbCol = oRg.Columns.Count xString = UserForm2.RefEdit2 Set tRg = Range(xString) 'Range("a1").Formula For i = 1 To nmbRow     For j = 1 To nmbCol          xString = oRg.Cells(i, j).Formula          tRg.Cells(j, i).Formula = xString     Next j Next i 'Selection.PasteSpecial Paste:=xlPasteAll, _ '                       Operation:=xlNone, _ '                       SkipBlanks:=False, _ '                       Transpose:=True End If End Sub Sub kcFindFormulaCell() Dim rg As Range Set rg = ActiveSheet.UsedRange For Each cell In rg   'If Left(cell.Formula, 1) = "=" Then   If cell.HasFormula Then     'cell.Interior.ColorIndex = 6     'cell.Font.Color = RGB(0, 0, 0)     cell.Font.Underline = xlUnderlineStyleSingle     cell.Font.Italic = True   End If Next cell End Sub Function kcCellName(Target As Range)  kcCellName = Target.Address(False, False) End Function Function kcEq2txt(range_ As Range)   tmp = range_.Address   kcEq2txt = Range(tmp).Formula End Function Function kcFilename(Optional Extension) Dim lengthOfstring As Integer Dim tmpString As String 'tmpString = ThisWorkbook.Name 'what's the problem?? tmpString = ActiveWorkbook.Name  If IsError(Extension) = True Then    tmp = tmpString  Else    If Extension = True Then      tmp = tmpString    Else      lenghthOfstring = Len(tmpString)      tmp = Left(tmpString, lenghthOfstring - 5)    End If  End If  kcFilename = tmp End Function Function kcLinearIntp(x1, x2, y1, y2, x0) kcLinearIntp = (y2 - y1) / (x2 - x1) * (x0 - x1) + y1 End Function Function kcEq2txt02(range_txt)   kcEq2txt02 = Range(range_txt).Formula End Function Function makeLinkAddress(SheetName, Optional fileName) If Not IsEmpty(fileName) Then  xStr = "[" + ActiveWorkbook.Name + "]" + SheetName + "!A1" Else  xStr = "[" + fileName + "]" + SheetName + "!A1" End If makeLinkAddress = xStr End Function