Newton - my VBA utility library for doing matrix multiplication and other useful automations during my finance days https://twitter.com/swyx/status/1327041894853922816
Attribute VB_Name = "Newton" | |
'Newton Utilities, written by swyx | |
'Project initiated Jan 1 2012 | |
'V1 released Feb 5 2012 | |
'V1.1 added and renamed functions, updated helpfiles Apr 8 2012 | |
'V1.2 spline interp extraction from surface, n_RandomWalk. released Jun 15 2012 | |
'V1.21 n_Corr, n_TangencyPortfolio, n_CovMat subsumed into n_Cov, fixed n_GetTimeSeries, n_AutoCorr, n_Lag, n_Pval, added PValues to n_Regress, n_Payback, n_ChartMakeScatter | |
'V1.22 n_Granger, pval for n_Corr, n_Divide, n_Curve, n_PriceIRS, upgraded n_BuildCurve | |
'V1.23 n_PriceFwd/Rate, n_AutoRegress/n_Remove_AutoRegress (needs work), augmented n_PriceOption for pricing FXO, digitals, and returning greeks | |
'V1.24 n_FXOVolCurve, n_FormatAsPercent linked to ctrl+shift+5, n_FormatInc/DecreaseDecimalPlace | |
'V1.25 modified n_Stdev, n_Cov and n_Corr to use zeromean and exponential decay factor, modified n_Stdev for Garman-Klass and Parkinson vol estimates | |
'V1.26 augmented n_PriceOption to price implied vol up to 6 d.p., implemented "True" greeks, n_ToggleBars | |
'V1.27 n_VolCurve, n_VegaBuckets. professionalized charting with n_MakeChartDefaults. Rearranged helpfile. fixed spline interpolation on n_ExtractFromCurve | |
'V1.28 n_PriceOptionPortfolio, n_ChartAddLine, upgraded n_RateCurve to incorporate mixed rates (needs work), n_CDate | |
'V1.29 fixed n_VlookupOrZero and n_ChartAlign2Axes. n_VlookupRow. n_Is3DChart. added straddles, riskies, and flies to n_PriceOption. added n_FindStrike. | |
'Shorthands used in this code's variable and function names: | |
' wWS indicates a "working worksheet" that is often passed to and from functions that need them in order to reduce the need for creating new worksheets | |
' A indicates a Variant containing either a 1 or 2 dimensional array | |
' M indicates a Variant containing strictly a 2 dimensional array | |
' V indicates a Variant containing strictly a 1 dimensional vector | |
' most functions accept and return variants because this is the most flexible way to code however this choice does make Newton more prone to runtime errors. | |
' With Add Watch, Call Stack(Ctrl+L) and intelligent F8-ing, the cost of this is negligible. | |
'Shortcuts for Most Used Functions | |
' n_P 'n_Paste | |
' n_T 'n_Transpose | |
' n_G 'n_GetRangeValues | |
' n_EC/ER 'n_Extract | |
' n_IS 'n_IntegerSequence | |
' max/min 'worksheetfunction.max/min | |
' scroff/scron 'Turn Application.ScreenUpdating and other similar things off/on. for faster vba execution. | |
' Ctrl+Shift+2/3 'increase/decrease decimal points | |
' Ctrl+Shift+L/B/S 'Make bar/line/scatter chart | |
' Ctrl+Shift+F3 'Make 3d surface chart | |
' Ctrl+Shift+2 'With 2-3 chart selected, create second axis | |
' Ctrl+Shift+W/A/S/D 'With 3-D chart selected, rotate chart | |
' Ctrl+Shift+1 'Cycle through fill colors on cell | |
' Ctrl+Shift+F2 'Add line to chart | |
'----------Custom Enums, Types, and Declarations----------- | |
'Public Enum n_Diff_Enum | |
'Public Enum n_Direction_Enum | |
'Public Enum n_Regress_Enum | |
'Public Enum n_RowCol_Enum | |
'Public Enum n_Curve_Enum | |
'Public Enum n_PriceOption_Enum | |
'----------Financial Utilities: Pricing----------- | |
' n_TangencyPortfolio 'output vector of weights using [inv(S)*z]/[(row vector of ones)*inv(S)*z)] where S = covmat and z = excess returns expected | |
' n_Payback 'calculate payback period | |
' n_ToTick/Dec 'bond price conversion functions | |
' n_PriceOption 'price equity/FX vanilla/digital options (including greeks and IV). NEEDS WORK to find implied vol of short rate futures (needs lognormal law) | |
' n_FindStrike 'n_FindStrike | |
' n_PriceOptionPortfolio 'portfolios of options | |
' n_PriceIRS 'price swap given fwd curve | |
' n_PriceFwd/Rate 'price forward FX/Int. rate | |
'----------Financial Utilities: Data----------- | |
' n_GetTimeSeries 'returns the string for bbg historical data. (NEEDS WORK) | |
' n_MapTimeSeries 'map one time series of dates and data to another vector of dates, interpolating missing dates | |
' n_RandomWalk 'simulate one or more random walks | |
' n_Lag 'takes a vector, outputs matrix of lagged vectors properly aligned. lag 0 on left, lag X on right | |
' n_FuturesMonthCode 'return the futures month letter given a integer or 3 letter uppercase representing a month | |
' n_ConvertAmericanDateString 'Convert american date formats into date serials | |
' n_CDate 'convert common financial things to dates | |
' n_RateCurve 'convert to/from par/fwd/zcb curve | |
' n_FXOVolCurve 'build vol curve given ATM, RR, BFs | |
' n_VolCurve 'convert spot vols to fwd vols | |
' n_VegaBuckets 'convert spot vega buckets to fwd buckets | |
'----------Statistical Utilities----------- | |
' n_AutoCorr 'autocorrelation/regression of time series fed in as column aligned matrix | |
' n_AutoRegress/n_Remove_Autoregress 'autoregression / remove autoregressive components, return residuals (NEEDS WORK) | |
' n_Granger 'tests granger causality | |
' n_Eigen/Vector/Value 'first column is eigenvalues, the rest eigenvectors | |
' n_QR 'QR decomposition | |
' n_Eig 'Eigenvalue/vectors by QR algorithm | |
' n_PCA/PrinCompTransform/Regress 'PCA | |
' n_Pval 'Returns the t-dist p-value | |
' n_Hist 'Histogram table. First column is bucket start. second col is bucket end. last col is % frequency. | |
' n_ANOVA 'feed in any number of data arrays of diff length. returns P value of anova F test | |
' n_DickeyFuller 'performs DF test. Returns p value if no % level supplied. Returns true if % level supplied and series is stationary | |
' n_Regress 'regress. options to return regression statistics other than coefficients | |
' n_AutoRegress 'return a vector of significant lags | |
' n_Residuals 'obtains a vector of regression residuals | |
'----------Spreadsheet Utilities------------ | |
' n_Interpolate '(log)linearly interpolate a point at a given time given two other points and times | |
' n_FormatColors 'most used colors (linked to keyboard shortcut) | |
' n_FormatRangeAsPercent 'format range as percent (linked to keyboard shortcut) | |
' n_FormatIncr/DecreaseDecimalPlace 'duh (linked to keyboard shortcut) | |
' n_ChartMakeBar/Line/Scatter 'default settings for making charts (linked to keyboard shortcut) | |
' n_ChartAddLine 'add vertical lines on time series graphs (linked to keyboard shortcut) | |
' n_Is3DChart 'boolean for 3d charts | |
' n_ChartRotateSurfaceUp/DownLeft/Right 'surface chart rotations (linked to keyboard shortcut) | |
' n_HardCode 'hardcode a single cell or range of cells (given the first cell) | |
' n_LastCell 'Find the last cell by searching | |
' n_LastRow 'Find the number of the last row (given first cell) | |
' n_AutoFilterOff 'turn Autofilter off, works for both 2003 and 2007 | |
' n_ClearWorksheet 'Sets pointer to a worksheet, clears it. Makes WS if it doesnt exist | |
' n_DeleteSheet 'quiet delete | |
' n_DoesSheetExist 'check if it exists, boolean | |
' n_FillEmptyRange 'if there are empty patches in a range e.g. a pivottable, this will fill values down | |
' n_FillDown 'just like double clicking bottom right of the cell | |
' n_RangeClearContents 'clear a range's contents just giving the first cell | |
' n_RangeAutoFit 'just autofits a cell and anything to its right | |
' n_BlankIfNA/IfNA 'BlankIfNA/IfNA UDF - returns whatever is fed in, except if its NA, in which case it returns something else, by default "" | |
'----------File Input/Output------------- | |
' n_EmailRange 'emails the given range, with option to autosend or not. | |
' n_EmailSheet 'emails the worksheet as attached workbook, with option to autosend or not. | |
' n_AccessOpenWorkbook 'if a given file from a filepath is open, set the pointer to it. | |
'if it is not, gives option to call GetFileCheckFileAndOpen | |
' n_GetFolder 'like Application.Getopenfilename but for choosing folders. | |
' n_FindDesktopPath 'Returns the desktop path for this computer | |
' n_GetFileCheckFileAndOpen 'opens a dialog for user to find the file, checks it, sets pointer. Loops if fails the check. | |
' n_CheckFileAndOpen 'checks and sets workbook pointer | |
' n_SaveWorkbookAsNewFile 'saveas with options for reopening old file | |
' n_Close 'quiet close | |
' n_DeleteFile 'move to recycle bin instead of total delete (Kill) | |
'----------Core Utilities------------ | |
' scroff/scron | |
' n_PasteValue/Formula 'paste a given array, given the first cell to paste in. Use value2 to avoid annoying currency and date problems | |
' n_GetRangeValue/Formula 'get an array of values from the first cell | |
' n_GetAllValues/Formulas 'get an array of all values from any worksheet | |
' n_RangeEnd 'returns a bigger range. as though you had the range selected then presed ctrl+shift+down or ctrl+shift+down+right or etc | |
' n_Wait 'wait a number of seconds | |
' n_UpdateStatus 'for updating status of program on long programs | |
' n_Transpose 'better than worksheetfunction.transpose as it does not compress 2 dimensional vectors to 1 dimension | |
' n_Is1Dim 'checks if a supplied array is 1 dimensional. | |
' n_Ensure1DArray 'returns the array, forced to 1 dimensional. by default forces 2d array to column | |
' n_Ensure2DArray 'returns the array, forced to 2 dimensional. by default forces 1d array to column | |
' n_CheckAllSame 'checks that everything in an array is the same value | |
' n_WhereInArray 'finds location of something in a 1 dimensional array. returns false if not in the array at all. | |
' n_Extract (Col/Row) 'extract one or more columns and rows from given matrix | |
' n_ColNum2Letter 'takes a number, gives the corresponding column letters. | |
'----------data processing/array operations----------- | |
' n_Filter 'Returns a shorter array filtered with only the rows containing things specified in FilterCriterion in their FilterColumn. Some variations allowed. | |
' n_PivotTable 'virtual pivot table | |
' n_GetUniqueArray 'get unique array | |
' n_Sort 'sorts array | |
' n_StringFind 'finds a string within a string, returns false if not there | |
' n_VlookupOrZero 'vlookup single element; if not found, by default return zero | |
' n_VlookupRow 'vlookup a row; if not found, by default return zero | |
' n_ArrayVlookup 'vlookup an entire column in an array, by default fill NAs with zero | |
' n_Append 'adds one column/row to an array to the Back of an array | |
' n_Insert 'adds one column/row to an array to the Start of an array | |
' n_Copy 'copies one column or row from one matrix to the other matrix. negative ToNumber to add to end of row. | |
' n_Array 'initialize array with 0's by default | |
'----------Matlab----------- | |
'-Generators- | |
' n_IntegerSequence 'returns a column array with increasing integers. analogous to start:1:end | |
' n_Eye 'identity matrix | |
' n_RandU 'returns a random number between 2 supplied numbers ~ U(a,b). option for integers | |
' n_RandN 'returns a random number drawn from a normal distribution, default std normal. ~ N(mean,stdev) | |
' n_BuildCurve/Surface 'builds a curve/surface matrix for later extraction | |
' n_SmoothCurve 'smooths out a curve according to polynomial regression | |
' n_ExtractFromCurve/Surface 'extracts from a built curve/surface | |
' n_ExtractCurveFromSurface 'supply either a row or col coord. returns curve. Row coord takes precedence. | |
' n_CubicSpline 'extract value from curve via cubic spline | |
'-Cheap Matrix Operations- | |
' max/min | |
' n_isFactor 'checks if first number is a factor of second number, incl decimals | |
' n_Diff 'first difference (options for percentage, log fdiffs) | |
' n_Stdev 'stdevs - choices of exponential weighting, zero mean, Parkinson and Garman-Klass | |
' n_Mean/Sum 'get row vector sum/means/stdev of columns | |
' n_DeMean/DeStdev 'remove means of column | |
' n_Mmult 'Matrix multiplication capable of handling large matrices | |
' n_Cov 'unbiased covariance (excel gets it wrong) | |
' n_CovMat 'get covariance matrix of column oriented data | |
' n_Corr 'get corr matrix of column oriented data | |
' n_Join 'join similar sized matrices. left-right or top-bottom | |
' n_DotProduct/n_Divide 'dot product, or divide | |
' n_Add/Pow 'matrix add (or subtract)/power | |
' n_CumSum/Prod/Max 'cumsum (faster than using generatetrailing). cummax is useful for calculating max drawdown | |
' n_Log 'log the whole matrix | |
' n_GenerateTrailing 'trailing functions (slow) | |
' n_RepMat 'Repeat Matrix | |
' n_FlipUD/LR 'flips a given array horizontally or vertically | |
' n_VectorLength 'multidimensional vector length, with or without directional sign | |
' n_IsSimilar 'boolean for similar matrices | |
' n_Minor 'get a minor matrix from a given matrix | |
' n_FloatingPointZero 'zero out floating point numbers lower than a given sigfig tolerance. basically for display purposes | |
'----------Misc----------- | |
' n_KillProcess 'ends the processs of any executable you name. equivalent to ctrl+alt+del -> end task | |
' n_Percent 'format as percentage | |
' n_ToggleBars 'hide the toolbars/ribbon | |
'-------------------------- end ------------------------ | |
Option Explicit | |
Option Base 1 | |
'Enums | |
Public Enum n_Diff_Enum | |
firstdiff = 1 | |
logdiff = 2 | |
percentdiff = 3 | |
End Enum | |
Public Enum n_Direction_Enum | |
DirNone | |
DirDown | |
DirRight | |
DirDownRight | |
DirRightDown | |
End Enum | |
Public Enum n_Regress_Enum | |
coeffs | |
CoeffsStdErrors | |
PValues | |
Rsquared | |
YStdErrors | |
FStat | |
degf | |
SumSquaresRegression | |
SumSquaresResidual | |
End Enum | |
Public Enum n_RowCol_Enum | |
nRow | |
nCol | |
End Enum | |
Public Enum n_RateCurve_Enum | |
nZCB | |
nFut | |
nPar | |
nFwd | |
nDF | |
End Enum | |
Public Enum n_PriceOption_Enum | |
Premium0 | |
Delta1 | |
Gamma2 | |
Vega3 | |
Theta4 | |
ImpliedVol5 | |
TrueGreekUpOnly6 | |
TrueGreekDownOnly7 | |
TrueGreekUpAndDown8 | |
End Enum | |
'-------------------------- n_killprocess------------------------ | |
Private Const PROCESS_ALL_ACCESS = &H1F0FFF | |
Type PROCESSENTRY32 | |
dwSize As Long | |
cntUsage As Long | |
th32ProcessID As Long | |
th32DefaultHeapID As Long | |
th32ModuleID As Long | |
cntThreads As Long | |
th32ParentProcessID As Long | |
pcPriClassBase As Long | |
dwFlags As Long | |
szexeFile As String * 260 | |
End Type | |
Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long | |
Declare Function ProcessFirst Lib "kernel32.dll" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long | |
Declare Function ProcessNext Lib "kernel32.dll" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long | |
Declare Function CreateToolhelpSnapshot Lib "kernel32.dll" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long | |
Declare Function TerminateProcess Lib "kernel32.dll" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long | |
Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long | |
'-------------------------- n_killprocess------------------------ | |
'-------------------------- n_DeleteFile------------------------ | |
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long 'n_DeleteFile | |
Type SHFILEOPSTRUCT | |
hwnd As Long | |
wFunc As Long | |
pFrom As String | |
pTo As String | |
fFlags As Integer | |
fAnyOperationsAborted As Boolean | |
hNameMappings As Long | |
lpszProgressTitle As String | |
End Type | |
'-------------------------- n_DeleteFile------------------------ | |
Sub n_CtrlShiftF3() | |
Call n_ChartMake3D | |
End Sub | |
Sub n_CtrlShiftF2() | |
Call n_ChartAddLine | |
End Sub | |
Sub n_CtrlShift1() | |
Call n_FormatColors | |
End Sub | |
Sub n_CtrlShift2() | |
Call n_ChartAlign2Axes 'or n_FormatIncreaseDecimalPlace | |
End Sub | |
Sub n_CtrlShift3() | |
Call n_FormatDecreaseDecimalPlace | |
End Sub | |
Sub n_CtrlShift5() | |
Call n_FormatRangeAsPercent(Selection) | |
End Sub | |
Sub n_CtrlShiftL() | |
Call n_ChartMakeLine | |
End Sub | |
Sub n_CtrlShiftB() | |
Call n_ChartMakeBar | |
End Sub | |
Sub n_CtrlShiftS() | |
Call n_ChartRotateSurfaceDown 'or n_ChartMakeScatter | |
End Sub | |
Sub n_CtrlShiftW() | |
Call n_ChartRotateSurfaceUp | |
End Sub | |
Sub n_CtrlShiftA() | |
Call n_ChartRotateSurfaceLeft | |
End Sub | |
Sub n_CtrlShiftD() | |
Call n_ChartRotateSurfaceRight | |
End Sub | |
'----------Financial Utilities: Pricing----------- | |
Function n_TangencyPortfolio(CovMat, ExpRet) | |
If UBound(CovMat) <> UBound(ExpRet) Then Call Err.Raise(0) | |
Dim ones | |
ones = n_Array(1, UBound(CovMat), 1) | |
n_TangencyPortfolio = n_MMult(WorksheetFunction.MInverse(CovMat), ExpRet) | |
n_TangencyPortfolio = n_DotProduct(n_TangencyPortfolio, 1 / n_MMult(n_MMult(ones, WorksheetFunction.MInverse(CovMat)), ExpRet)) | |
End Function | |
Function n_Payback(year0, subsequentyears) | |
Dim i | |
n_Payback = 0 | |
For Each i In subsequentyears | |
If year0 + i > 0 Then | |
n_Payback = n_Payback + Abs(year0 / i) | |
Exit For | |
End If | |
year0 = year0 + i | |
n_Payback = n_Payback + 1 | |
Next i | |
End Function | |
Function n_ToTick(ByVal x As Double) | |
Dim handle As Integer, ticks As Integer, eighths As Integer, sign As String | |
If x < 0 Then | |
x = Abs(x) + 1 / 512 | |
sign = "-" | |
Else | |
x = x + 1 / 512 ' for rounding | |
End If | |
handle = Int(x) | |
ticks = Int((x - handle) * 32) | |
eighths = Int((x - handle - ticks / 32) * 256) | |
If (ticks < 10) Then | |
n_ToTick = str(handle) & "-0" & Trim(str(ticks)) | |
Else | |
n_ToTick = str(handle) & "-" & Trim(str(ticks)) | |
End If | |
If (eighths = 4) Then | |
n_ToTick = n_ToTick & "+" | |
ElseIf (eighths <> 0) Then | |
n_ToTick = n_ToTick & Trim(str(eighths)) | |
End If | |
If sign = "-" Then | |
n_ToTick = sign & n_ToTick | |
End If | |
End Function | |
Function n_ToDec(ByVal x As String) | |
Dim handle As Integer, ticks As String, dec As Double, eighth As String | |
If Len(x) > 3 Then | |
If (InStr(x, ".") > 100) Then | |
handle = Split(x, ".", 2)(0) | |
ticks = Split(x, ".", 2)(1) | |
Else | |
handle = Split(x, "-", 2)(0) | |
ticks = Split(x, "-", 2)(1) | |
End If | |
If Len(ticks) > 2 Then | |
eighth = Split(ticks, ".", 2)(1) | |
eighth = eighth / 10 ^ Len(eighth) * 8 | |
'If eighth = "+" Then | |
'eighth = 4 | |
'End If | |
Else | |
eighth = 0 | |
End If | |
ticks = Left(ticks, 2) | |
If Len(ticks) = 1 Then ticks = ticks * 10 | |
dec = ticks / 32 + eighth / 256 | |
n_ToDec = handle + dec | |
Else | |
n_ToDec = x / 1 | |
End If | |
End Function | |
Function n_FindStrike(ByVal CallOrPut, ByVal Spot As Double, ByVal DeltaStrike As Double, VolOrprice As Double, YearsToExpiry As Double, Optional IntRateOrQuotedCcyRate As Double = 0, Optional DivYieldOrBaseCcyRate As Double = 0, Optional QuotedCcyDayCount = 0, Optional BaseCcyDayCount = 0) | |
Dim table, i | |
If DeltaStrike > 1 Then DeltaStrike = DeltaStrike / 100 | |
Select Case CallOrPut | |
Case "Put", "PUT", "put", "P", "p", False | |
DeltaStrike = 1 - DeltaStrike | |
End Select | |
table = n_Add(Spot, n_IS(-40, 40), Spot / -1000) | |
table = n_Join(table, table, True) | |
For i = LBound(table) To UBound(table) | |
table(i, 1) = n_PriceOption("Call", CDbl(Spot), CDbl(table(i, 2)), VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, Delta1) | |
Next i | |
n_FindStrike = n_ExtractFromCurve(table, DeltaStrike, True) | |
End Function | |
Function n_PriceOption(CallOrPut, Spot As Double, Strike, VolOrprice As Double, YearsToExpiry As Double, Optional IntRateOrQuotedCcyRate As Double = 0, Optional DivYieldOrBaseCcyRate As Double = 0, Optional QuotedCcyDayCount = 0, Optional BaseCcyDayCount = 0, Optional ReturnGreek As n_PriceOption_Enum = Premium0, Optional TrueGreekSpotBump As Double = 0, Optional TrueGreekVolBump As Double = 0, Optional IsDigitalOption As Boolean = False, Optional IsShortRateFutureOption As Boolean = False) | |
'combos | |
Select Case CallOrPut | |
Dim d25 As Double, d75 As Double | |
Case "Straddle", "S", "s", "STRADDLE" | |
If Strike = "ATM" Then Strike = n_FindStrike("Call", Spot, 0.5, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
d25 = n_PriceOption("Put", Spot, Strike, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) | |
d75 = n_PriceOption("Call", Spot, Strike, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) | |
n_PriceOption = d25 + d75 | |
Exit Function | |
Case "RR", "Riskie", "Risk Reversal", "rr", "R", "r" | |
If CInt(Strike) = 10 Then | |
d25 = n_FindStrike("Put", Spot, 0.1, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
d75 = n_FindStrike("Call", Spot, 0.1, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
Else | |
d25 = n_FindStrike("Put", Spot, 0.25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
d75 = n_FindStrike("Call", Spot, 0.25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
End If | |
n_PriceOption = n_PriceOption("Call", Spot, d75, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) _ | |
- n_PriceOption("Put", Spot, d25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) | |
Exit Function | |
Case "Fly", "FLY", "Butterfly", "Bfly", "fly", "F", "f" | |
Dim d50 As Double | |
d50 = n_FindStrike("Call", Spot, 0.5, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
If CInt(Strike) = 10 Then | |
d25 = n_FindStrike("Put", Spot, 0.1, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
d75 = n_FindStrike("Call", Spot, 0.1, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
Else | |
d25 = n_FindStrike("Put", Spot, 0.25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
d75 = n_FindStrike("Call", Spot, 0.25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount) | |
End If | |
n_PriceOption = n_PriceOption("Put", Spot, d25, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) _ | |
+ n_PriceOption("Call", Spot, d75, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) _ | |
- n_PriceOption("Straddle", Spot, d50, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, IsDigitalOption, IsShortRateFutureOption) | |
Exit Function | |
End Select | |
'input processing | |
Select Case CallOrPut | |
Case "Put", "PUT", "put", "P", "p", False | |
CallOrPut = "Put" | |
Case Else | |
CallOrPut = "Call" | |
End Select | |
If IsShortRateFutureOption Then | |
Strike = (100 - Strike) / 100 | |
Spot = (100 - Spot) / 100 | |
VolOrprice = VolOrprice / 100 | |
End If | |
If QuotedCcyDayCount <> 0 Then IntRateOrQuotedCcyRate = 365 / (YearsToExpiry * 365) * Log(1 + IntRateOrQuotedCcyRate * (YearsToExpiry * 365) / QuotedCcyDayCount) | |
If BaseCcyDayCount <> 0 Then DivYieldOrBaseCcyRate = 365 / (YearsToExpiry * 365) * Log(1 + DivYieldOrBaseCcyRate * (YearsToExpiry * 365) / BaseCcyDayCount) | |
'return intrinsic value | |
If CallOrPut = "Put" Then | |
n_PriceOption = WorksheetFunction.max(Strike - Spot, 0) | |
Else | |
n_PriceOption = WorksheetFunction.max(Spot - Strike, 0) | |
End If | |
If VolOrprice <= 0 Or YearsToExpiry <= 0 Then Exit Function | |
'return implied VolOrPrice | |
If ReturnGreek = ImpliedVol5 Then | |
n_PriceOption = 0 | |
'If (CallOrPut = "Call" And VolOrPrice <= Spot - Strike) Or (CallOrPut = "Put" And VolOrPrice <= Strike - Spot) Then Exit Function | |
Dim voltable, i | |
voltable = n_DotProduct(n_IS(0, 300), 0.01) 'build VolOrPrice curve | |
voltable = n_Join(voltable, voltable, True) | |
For i = 1 To UBound(voltable) | |
voltable(i, 1) = n_PriceOption(CallOrPut, Spot, Strike, CDbl(voltable(i, 2)), YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, , , , , , IsDigitalOption) | |
Next i | |
n_PriceOption = Round(n_ExtractFromCurve(voltable, VolOrprice), 3) | |
voltable = n_Add(n_PriceOption, n_DotProduct(n_IS(-100, 100), 0.001)) 'build narrow VolOrPrice curve around this IV | |
voltable = n_Join(voltable, voltable, True) | |
For i = 1 To UBound(voltable) | |
voltable(i, 1) = n_PriceOption(CallOrPut, Spot, Strike, CDbl(voltable(i, 2)), YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, , , , , , IsDigitalOption) | |
Next i | |
n_PriceOption = Round(n_ExtractFromCurve(voltable, VolOrprice), 4) | |
voltable = n_Add(n_PriceOption, n_DotProduct(n_IS(-100, 100), 0.0001)) 'build narrow VolOrPrice curve around this IV | |
voltable = n_Join(voltable, voltable, True) | |
For i = 1 To UBound(voltable) | |
voltable(i, 1) = n_PriceOption(CallOrPut, Spot, Strike, CDbl(voltable(i, 2)), YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, , , , , , IsDigitalOption) | |
Next i | |
n_PriceOption = Round(n_ExtractFromCurve(voltable, VolOrprice), 5) | |
voltable = n_Add(n_PriceOption, n_DotProduct(n_IS(-100, 100), 0.00001)) 'build narrow VolOrPrice curve around this IV | |
voltable = n_Join(voltable, voltable, True) | |
For i = 1 To UBound(voltable) | |
voltable(i, 1) = n_PriceOption(CallOrPut, Spot, Strike, CDbl(voltable(i, 2)), YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, , , , , , IsDigitalOption) | |
Next i | |
n_PriceOption = n_ExtractFromCurve(voltable, VolOrprice) | |
Exit Function | |
End If | |
'"True greeks" | |
If Abs(TrueGreekVolBump) + Abs(TrueGreekSpotBump) > 0 Then | |
Dim a, b, c, d | |
d = n_PriceOption(CallOrPut, Spot, Strike, VolOrprice, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, , , , IsDigitalOption) | |
a = Abs(n_PriceOption(CallOrPut, Spot + TrueGreekSpotBump, Strike, VolOrprice + TrueGreekVolBump, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, , , , IsDigitalOption) - d) | |
b = Abs(n_PriceOption(CallOrPut, Spot - TrueGreekSpotBump, Strike, VolOrprice + TrueGreekVolBump, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, , , , IsDigitalOption) - d) | |
c = Abs(n_PriceOption(CallOrPut, Spot + TrueGreekSpotBump, Strike, VolOrprice - TrueGreekVolBump, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, , , , IsDigitalOption) - d) | |
d = Abs(n_PriceOption(CallOrPut, Spot - TrueGreekSpotBump, Strike, VolOrprice - TrueGreekVolBump, YearsToExpiry, IntRateOrQuotedCcyRate, DivYieldOrBaseCcyRate, QuotedCcyDayCount, BaseCcyDayCount, , , , IsDigitalOption) - d) | |
If ReturnGreek = TrueGreekUpOnly6 Then n_PriceOption = a Else n_PriceOption = (a + b + c + d) / 4 | |
If ReturnGreek = TrueGreekDownOnly7 Then n_PriceOption = d | |
Exit Function | |
End If | |
'normal option pricing | |
Dim d1 As Double, d2 As Double, nd1 As Double, nd2 As Double, nnd1 As Double, nnd2 As Double, ninvd1 As Double, ninvd2 As Double | |
d1 = (Log(Spot / Strike) + (IntRateOrQuotedCcyRate - DivYieldOrBaseCcyRate + 0.5 * VolOrprice ^ 2) * YearsToExpiry) / (VolOrprice * Sqr(YearsToExpiry)) | |
d2 = (Log(Spot / Strike) + (IntRateOrQuotedCcyRate - DivYieldOrBaseCcyRate - 0.5 * VolOrprice ^ 2) * YearsToExpiry) / (VolOrprice * Sqr(YearsToExpiry)) | |
nd1 = Application.NormSDist(d1) | |
nd2 = Application.NormSDist(d2) | |
nnd1 = Application.NormSDist(-d1) | |
nnd2 = Application.NormSDist(-d2) | |
ninvd1 = (1 / ((2 * WorksheetFunction.Pi())) ^ 0.5) * Exp(-1 * (d1 ^ 2 / 2)) '=(1/SQRT(2*PI()))*EXP(-1*(d1^2/2)) | |
ninvd2 = (1 / ((2 * WorksheetFunction.Pi())) ^ 0.5) * Exp(-1 * (d2 ^ 2 / 2)) '=(1/SQRT(2*PI()))*EXP(-1*(d1^2/2)) | |
'theoretical greeks | |
If IsDigitalOption Then | |
Select Case ReturnGreek | |
Case Delta1 | |
n_PriceOption = Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * ninvd2 / (VolOrprice * Spot * YearsToExpiry ^ 0.5) | |
If CallOrPut = "Put" Then n_PriceOption = -1 * n_PriceOption | |
Case Gamma2 | |
n_PriceOption = -Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * d1 * ninvd2 / (VolOrprice ^ 2 * Spot ^ 2 * YearsToExpiry) | |
If CallOrPut = "Put" Then n_PriceOption = -1 * n_PriceOption | |
Case Theta4 | |
If CallOrPut = "Call" Then | |
n_PriceOption = (IntRateOrQuotedCcyRate * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nd2 + Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * ninvd2 * (d1 / (2 * YearsToExpiry) - (IntRateOrQuotedCcyRate - DivYieldOrBaseCcyRate) / (VolOrprice * YearsToExpiry))) / 365 | |
Else | |
n_PriceOption = (IntRateOrQuotedCcyRate * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * (1 - nd2) - Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * ninvd2 * (d1 / (2 * YearsToExpiry) - (IntRateOrQuotedCcyRate - DivYieldOrBaseCcyRate) / (VolOrprice * YearsToExpiry))) / 365 | |
End If | |
Case Vega3 | |
n_PriceOption = -Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * ninvd2 * (YearsToExpiry ^ 0.5 + d2 / VolOrprice) / 100 | |
If CallOrPut = "Put" Then n_PriceOption = -1 * n_PriceOption | |
Case Else 'just calculate the option Premium0 | |
If CallOrPut = "Call" Then | |
n_PriceOption = Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nd2 | |
Else | |
n_PriceOption = Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * (1 - nd2) | |
End If | |
End Select | |
Else | |
Select Case ReturnGreek | |
Case Delta1 | |
n_PriceOption = nd1 * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) | |
If CallOrPut = "Put" Then n_PriceOption = -(1 - n_PriceOption) | |
Case Gamma2 | |
n_PriceOption = (ninvd1 * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry)) / (Spot * VolOrprice * (YearsToExpiry) ^ 0.5) | |
Case Theta4 | |
If CallOrPut = "Call" Then | |
n_PriceOption = ((-(Spot * ninvd1 * VolOrprice * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry)) / (2 * YearsToExpiry ^ 0.5)) + DivYieldOrBaseCcyRate * Spot * nd1 * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) - (IntRateOrQuotedCcyRate * Strike * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nd2)) / 365 | |
Else | |
n_PriceOption = ((-(Spot * ninvd1 * VolOrprice * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry)) / (2 * YearsToExpiry ^ 0.5)) - DivYieldOrBaseCcyRate * Spot * nd1 * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) + (IntRateOrQuotedCcyRate * Strike * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nd2)) / 365 | |
End If | |
Case Vega3 | |
n_PriceOption = Spot * YearsToExpiry ^ 0.5 * ninvd1 * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) / 100 | |
Case Else 'just calculate the option Premium0 | |
If CallOrPut = "Call" Then | |
n_PriceOption = Spot * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) * nd1 - Strike * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nd2 | |
Else | |
n_PriceOption = -Spot * Exp(-DivYieldOrBaseCcyRate * YearsToExpiry) * nnd1 + Strike * Exp(-IntRateOrQuotedCcyRate * YearsToExpiry) * nnd2 | |
End If | |
End Select | |
End If | |
End Function | |
Function n_PriceOptionPortfolio(ByVal Amounts, ByVal CallOrPut, ByVal Strike, ByVal YearsToExpiry, ByVal Spot As Double, ByVal VolSurface, Optional IntRateOrQuotedCcyRate, Optional DivYieldOrBaseCcyRate, Optional QuotedCcyDayCount = 0, Optional BaseCcyDayCount = 0, Optional ReturnGreek As n_PriceOption_Enum = Premium0, Optional TrueGreekSpotBump As Double = 0, Optional TrueGreekVolBump As Double = 0, Optional ByVal IsDigitalOption = False, Optional ByVal IsShortRateFutureOption = False) As Double | |
Dim i, output, homerate, fornrate, temp | |
If ReturnGreek = ImpliedVol5 Then Err.Raise (1) 'why are you pricing implied vol of a portfolio? | |
Amounts = n_Ensure1DArray(Amounts) | |
CallOrPut = n_Ensure1DArray(CallOrPut) | |
VolSurface = n_Ensure2DArray(VolSurface) | |
If IsObject(IntRateOrQuotedCcyRate) Then IntRateOrQuotedCcyRate = n_Ensure2DArray(IntRateOrQuotedCcyRate) | |
If IsObject(DivYieldOrBaseCcyRate) Then DivYieldOrBaseCcyRate = n_Ensure2DArray(DivYieldOrBaseCcyRate) | |
If IsObject(IsDigitalOption) Then IsDigitalOption = IsDigitalOption.Value | |
If Not IsArray(IsDigitalOption) Then IsDigitalOption = n_Array(CallOrPut, , IsDigitalOption) | |
If IsObject(IsShortRateFutureOption) Then IsShortRateFutureOption = IsShortRateFutureOption.Value | |
If Not IsArray(IsShortRateFutureOption) Then IsShortRateFutureOption = n_Array(CallOrPut, , IsShortRateFutureOption) | |
For i = 1 To UBound(CallOrPut) | |
If IsArray(IntRateOrQuotedCcyRate) Then | |
homerate = n_ExtractFromCurve(IntRateOrQuotedCcyRate, YearsToExpiry(i), True) | |
Else | |
homerate = IntRateOrQuotedCcyRate | |
End If | |
If IsArray(DivYieldOrBaseCcyRate) Then | |
fornrate = n_ExtractFromCurve(DivYieldOrBaseCcyRate, YearsToExpiry(i), True) | |
Else | |
fornrate = DivYieldOrBaseCcyRate | |
End If | |
temp = CDbl(n_ExtractFromSurface(VolSurface, Strike(i), YearsToExpiry(i))) | |
output = output + Amounts(i) * n_PriceOption(CallOrPut(i), Spot, CDbl(Strike(i)), CDbl(temp), CDbl(YearsToExpiry(i)), CDbl(homerate), CDbl(fornrate), QuotedCcyDayCount, BaseCcyDayCount, ReturnGreek, TrueGreekSpotBump, TrueGreekVolBump, CBool(IsDigitalOption(i, 1)), CBool(IsShortRateFutureOption(i, 1))) | |
Next i | |
n_PriceOptionPortfolio = output | |
End Function | |
Function n_PriceIRS(ByVal FwdCurve, Optional TenorRowNumber = 0, Optional ByVal FwdDayCountBasisNumerators, Optional ByVal FwdDayCountBasisDenominator = 360, Optional ByVal FixedDayCountBasisNumerators, Optional ByVal FixedDayCountBasisDenominator = 360, Optional ByVal AmortizingNotional = 1) | |
'c% = pv of float / AmortizingNotional * sum of dfs | |
If TenorRowNumber <> 0 Then FwdCurve = n_Append(nRow, FwdCurve, TenorRowNumber - UBound(FwdCurve)) 'cut off irrelevant tenors; necessary | |
Dim df, PVofFloat, denominator, FloatLeg | |
df = n_EC(n_RateCurve(FwdCurve, nFwd, nDF, FwdDayCountBasisNumerators, FwdDayCountBasisDenominator), 2) | |
FloatLeg = n_Divide(n_DotProduct(n_EC(FwdCurve, 2), FwdDayCountBasisNumerators), FwdDayCountBasisDenominator) | |
PVofFloat = n_MMult(n_T(df), n_DotProduct(FloatLeg, AmortizingNotional)) | |
If IsArray(FixedDayCountBasisNumerators) Then | |
denominator = n_DotProduct(AmortizingNotional, n_DotProduct(df, FixedDayCountBasisNumerators)) | |
Else | |
denominator = n_DotProduct(AmortizingNotional, WorksheetFunction.sum(df)) | |
End If | |
n_PriceIRS = PVofFloat * FixedDayCountBasisDenominator / n_Sum(denominator) | |
End Function | |
Function n_PriceFwd(Spot, NumDaysForward, NumeratorRateAnnual, NumeratorRateDaycount, DenominatorRateAnnual, DenominatorRateDaycount) | |
n_PriceFwd = Spot * (1 + NumeratorRateAnnual * NumDaysForward / NumeratorRateDaycount) / (1 + DenominatorRateAnnual * NumDaysForward / DenominatorRateDaycount) | |
End Function | |
Function n_PriceFwdRate(NumeratorRateAnnual, NumeratorNumDays, DenominatorRateAnnual, DenominatorNumDays, Daycount) | |
n_PriceFwdRate = ((1 + NumeratorRateAnnual * NumeratorNumDays / Daycount) / (1 + DenominatorRateAnnual * DenominatorNumDays / Daycount) - 1) * Daycount / (NumeratorNumDays - DenominatorNumDays) | |
End Function | |
'----------Financial Utilities: Data----------- | |
Function n_GetTimeSeries(ByVal TickerString, ByVal StartDate, Optional EndDate, Optional FieldString As String = "PX_LAST", Optional DataFrequency As String = "Daily", Optional DisplayDates As Boolean = False) | |
Select Case LCase(DataFrequency) | |
Case "monthly" | |
DataFrequency = "cm" | |
Case Else | |
DataFrequency = "cd" | |
End Select | |
Dim datedisplay | |
If DisplayDates Then datedisplay = "S" Else datedisplay = "H" | |
n_GetTimeSeries = "=BDH(""" & TickerString _ | |
& """,""" & FieldString _ | |
& """," & StartDate _ | |
& "," & EndDate & ",""Dir=V"",""Dts=" & datedisplay _ | |
& """,""Sort=A"",""Quote=C"",""QtTyp=Y"",""Days=A"",""Per=" & DataFrequency & """,""DtFmt=D"",""UseDPDF=Y"",""cols=2;rows=777"")" | |
'''''''''may be useful code in future if bbg api is usable, however for now bbg refuses to let us load data while vba code is executing. smart guys. | |
' Dim WithEvents session As blpapicomLib.Session | |
' Dim refdataservice As blpapicomLib.service | |
' Dim req As blpapicomLib.Request | |
' | |
' Set Session = New blpapicomLib.Session | |
' Session.Start | |
' Session.OpenService "//blp/refdata" | |
' | |
' Set refdataservice = Session.GetService("//blp/refdata") | |
' Set req = refdataservice.CreateRequest("HistoricalDataRequest") | |
' | |
' req.GetElement("securities").AppendValue ("IBM US Equity") | |
' req.GetElement("fields").AppendValue ("PX_LAST") | |
' req.Set "returnRelativeDate", "TRUE" | |
' req.Set "periodicityAdjustment", "CALENDAR" | |
' req.Set "periodicitySelection", "DAILY" | |
' req.Set "StartDate", "CQ22009" | |
' req.Set "endDate", "CQ22010" | |
' req.Set "nonTradingDayFillMethod", "PREVIOUS_VALUE" | |
' req.Set "nonTradingDayFillOption", "ALL_CALENDAR_DAYS" | |
' req.Set "pricingOption", "PRICING_OPTION_YIELD" | |
' req.Set "overrideOption", "OVERRIDE_OPTION_CLOSE" | |
' req.Set "adjustmentFollowDPDF", "TRUE" | |
' | |
' Session.SendRequest req | |
End Function | |
Function n_MapTimeSeries(ByVal FromDatesAndData, ByVal ToDatesVector) | |
Dim FDD2, TDV2, ansvector, i, j, k | |
FDD2 = n_Sort(FromDatesAndData, 1, , xlAscending) | |
TDV2 = n_Ensure1DArray(n_Sort(ToDatesVector, 1, , xlAscending)) | |
ReDim ansarr(LBound(TDV2) To UBound(TDV2), LBound(FDD2, 2) To UBound(FDD2, 2) - 1) | |
For i = LBound(TDV2) To UBound(TDV2) | |
If TDV2(i) < FDD2(LBound(FDD2, 1), 1) Or TDV2(i) > FDD2(UBound(FDD2, 1), 1) Then | |
'skip | |
Else | |
For k = LBound(FDD2, 1) To UBound(FDD2, 1) | |
If TDV2(i) = FDD2(k, 1) Then | |
'copy! | |
For j = LBound(ansarr, 2) + 1 To UBound(ansarr, 2) + 1 | |
If IsNumeric(FDD2(k, j)) Then ansarr(i, j - 1) = FDD2(k, j) | |
Next j | |
Exit For | |
ElseIf TDV2(i) > FDD2(k, 1) And TDV2(i) < FDD2(k + 1, 1) Then | |
For j = LBound(ansarr, 2) + 1 To UBound(ansarr, 2) + 1 | |
'If FDD2(k + 1, j) <> 0 Then | |
If IsNumeric(FDD2(k, j)) Then ansarr(i, j - 1) = FDD2(k, j) + (FDD2(k + 1, j) - FDD2(k, j)) * (TDV2(i) - FDD2(k, 1)) / (FDD2(k + 1, 1) - FDD2(k, 1)) | |
'End If | |
Next j | |
Exit For | |
End If | |
Next k | |
End If | |
Next i | |
n_MapTimeSeries = ansarr | |
End Function | |
Function n_RandomWalk(Length, Optional StartValue = 1, Optional MeanRet = 0.001, Optional DailyStDev = 0.03, Optional numWalks = 1) | |
Dim output, rando | |
output = n_IS(1, CInt(Length)) | |
rando = n_Add(n_RandN(MeanRet, DailyStDev, Length - 1, numWalks), 1) | |
rando = n_Join(n_Array(1, numWalks, StartValue), rando) | |
rando = n_CumProd(rando) | |
n_RandomWalk = n_Join(output, rando, True) | |
End Function | |
Function n_Lag(DataVector, LagLength As Integer) | |
Dim output, i | |
output = n_Append(nRow, DataVector, -1 * LagLength) | |
For i = 1 To LagLength | |
output = n_Join(output, n_Insert(nRow, n_Append(nRow, DataVector, -1 * (LagLength - i)), -1 * i), True) | |
Next i | |
n_Lag = output | |
End Function | |
Public Function n_FuturesMonthCode(mth) | |
Select Case mth | |
Case 1, "JAN" | |
n_FuturesMonthCode = "F" | |
Case 2, "FEB" | |
n_FuturesMonthCode = "G" | |
Case 3, "MAR" | |
n_FuturesMonthCode = "H" | |
Case 4, "APR" | |
n_FuturesMonthCode = "J" | |
Case 5, "MAY" | |
n_FuturesMonthCode = "K" | |
Case 6, "JUN" | |
n_FuturesMonthCode = "M" | |
Case 7, "JUL" | |
n_FuturesMonthCode = "N" | |
Case 8, "AUG" | |
n_FuturesMonthCode = "Q" | |
Case 9, "SEP" | |
n_FuturesMonthCode = "U" | |
Case 10, "OCT" | |
n_FuturesMonthCode = "V" | |
Case 11, "NOV" | |
n_FuturesMonthCode = "X" | |
Case Else | |
n_FuturesMonthCode = "Z" | |
End Select | |
End Function | |
Public Function n_ConvertAmericanDateString(thestring As String) As Date | |
Dim a | |
a = Split(thestring, "/") | |
n_ConvertAmericanDateString = DateSerial(a(2), a(0), a(1)) | |
End Function | |
Function n_CDate(something) As Date | |
If IsObject(something) Then something = something.Value | |
If IsArray(something) Then | |
Dim i, j | |
For i = 1 To UBound(something, 1) | |
For j = 1 To UBound(something, 2) | |
something(i, j) = n_CDate(something(i, j)) | |
Next | |
Next | |
Else | |
If Len(CStr(something)) = 4 Then 'futures | |
Select Case UCase(Left(something, 3)) | |
Case "JAN" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 1, 15) | |
Case "FEB" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 2, 15) | |
Case "MAR" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 3, 15) | |
Case "APR" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 4, 15) | |
Case "MAY" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 5, 15) | |
Case "JUN" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 6, 15) | |
Case "JUL" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 7, 15) | |
Case "AUG" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 8, 15) | |
Case "SEP" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 9, 15) | |
Case "OCT" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 10, 15) | |
Case "NOV" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 11, 15) | |
Case "DEC" | |
n_CDate = DateSerial(2010 + CInt(Right(something, 1)), 12, 15) | |
End Select | |
End If | |
End If | |
End Function | |
Function n_FXOVolCurve(ATM, RR25, BF25, Optional RR10, Optional BF10) | |
Dim a | |
a = n_Append(nCol, Array(10, 25, 50, 75, 90)) | |
a(1, 2) = ATM + BF10 - RR10 / 2 | |
a(2, 2) = ATM + BF25 - RR25 / 2 | |
a(3, 2) = ATM | |
a(4, 2) = ATM + BF25 + RR25 / 2 | |
a(5, 2) = ATM + BF10 + RR10 / 2 | |
n_FXOVolCurve = a | |
End Function | |
Function n_VolCurve(ByVal SpotVols, Optional ByVal Tenors, Optional ReverseDirection As Boolean = False) | |
Dim i, a | |
SpotVols = n_Ensure2DArray(SpotVols) | |
Tenors = n_Ensure2DArray(Tenors) | |
If UBound(SpotVols, 2) = 1 And UBound(Tenors, 2) = 1 Then a = n_Join(Tenors, SpotVols, True) Else a = SpotVols | |
If ReverseDirection Then | |
For i = LBound(SpotVols) + 1 To UBound(SpotVols) | |
a(i, 2) = (a(i, 2)) ^ 2 * (a(i, 1) - a(i - 1, 1)) | |
a(i, 2) = ((a(i, 2) + a(i - 1, 1) * a(i - 1, 2) ^ 2) / a(i, 1)) ^ 0.5 | |
Next i | |
Else | |
For i = LBound(SpotVols) + 1 To UBound(SpotVols) | |
a(i, 2) = SpotVols(i, 1) * SpotVols(i, 2) ^ 2 - SpotVols(i - 1, 1) * SpotVols(i - 1, 2) ^ 2 | |
a(i, 2) = (a(i, 2) / (SpotVols(i, 1) - SpotVols(i - 1, 1))) ^ 0.5 | |
Next i | |
End If | |
n_VolCurve = a | |
End Function | |
Function n_VegaBuckets(ByVal SpotVegas, Optional ByVal Tenors, Optional ReverseDirection As Boolean = False) | |
Dim i, a, b | |
SpotVegas = n_Ensure2DArray(SpotVegas) | |
Tenors = n_Ensure2DArray(Tenors) | |
If UBound(SpotVegas, 2) = 1 And UBound(Tenors, 2) = 1 Then a = n_Join(Tenors, SpotVegas, True) Else a = SpotVegas | |
If ReverseDirection Then | |
For i = UBound(a) To LBound(a) + 2 Step -1 | |
a(i, 2) = a(i, 2) / (a(i, 1) - a(i - 1, 1)) * a(i, 1) | |
b = b * (a(i - 1, 1) - a(i - 2, 1)) / (a(i, 1) - a(i - 1, 1)) + a(i, 2) * (a(i - 1, 1) - a(i - 2, 1)) / a(i, 1) | |
a(i - 1, 2) = a(i - 1, 2) - b | |
Next | |
a(i, 2) = a(i, 2) / (a(i, 1) - a(i - 1, 1)) * a(i, 1) | |
b = b + a(i, 2) * (a(i - 1, 1) - 0) / a(i, 1) | |
a(i - 1, 2) = a(i - 1, 2) - b | |
Else | |
For i = UBound(a) To LBound(a) + 1 Step -1 | |
a(i - 1, 2) = a(i - 1, 2) + a(i, 2) - a(i, 2) * (a(i, 1) - a(i - 1, 1)) / a(i, 1) | |
a(i, 2) = a(i, 2) * (a(i, 1) - a(i - 1, 1)) / a(i, 1) | |
Next | |
End If | |
n_VegaBuckets = a | |
End Function | |
Function n_RateCurve(ByVal InputCurveTenorsAndRates, ByVal FromCurveType, ToCurveType As n_RateCurve_Enum, Optional ByVal FwdDayCountBasisNumerators = 360, Optional ByVal FwdDayCountBasisDenominator = 360) | |
On Error GoTo mainpart 'handles if input is an array of curve types. | |
n_RateCurve = InputCurveTenorsAndRates | |
If FromCurveType = ToCurveType Then Exit Function 'shortcut | |
mainpart: | |
Dim output, i, j, par, denominator, DFCurve, ZCBCurve | |
'process input to DF | |
If IsObject(FromCurveType) Then FromCurveType = FromCurveType.Value | |
If IsObject(InputCurveTenorsAndRates) Then InputCurveTenorsAndRates = InputCurveTenorsAndRates.Value | |
If Not IsArray(FromCurveType) Then FromCurveType = n_Array(InputCurveTenorsAndRates, , FromCurveType) | |
If Not IsArray(FwdDayCountBasisNumerators) Then FwdDayCountBasisNumerators = n_Array(InputCurveTenorsAndRates, , FwdDayCountBasisNumerators) | |
'make the swaps/futures tenors correct | |
For i = 1 To UBound(InputCurveTenorsAndRates) | |
If Not IsNumeric(InputCurveTenorsAndRates(i, 1)) Then | |
If InputCurveTenorsAndRates(i, 1) = "O/N" Then InputCurveTenorsAndRates(i, 1) = 1 / 365 | |
If InputCurveTenorsAndRates(i, 1) = "T/N" Then InputCurveTenorsAndRates(i, 1) = 2 / 365 | |
If InputCurveTenorsAndRates(i, 1) = "S/N" Then InputCurveTenorsAndRates(i, 1) = 3 / 365 | |
If UCase(Right(CStr(InputCurveTenorsAndRates(i, 1)), 1)) = "Y" Then InputCurveTenorsAndRates(i, 1) = CDbl(Left(CStr(InputCurveTenorsAndRates(i, 1)), Len(InputCurveTenorsAndRates(i, 1)) - 1)) | |
If UCase(Right(CStr(InputCurveTenorsAndRates(i, 1)), 1)) = "M" Then InputCurveTenorsAndRates(i, 1) = CDbl(Left(CStr(InputCurveTenorsAndRates(i, 1)), Len(InputCurveTenorsAndRates(i, 1)) - 1)) / 12 | |
If UCase(Right(CStr(InputCurveTenorsAndRates(i, 1)), 1)) = "W" Then InputCurveTenorsAndRates(i, 1) = CDbl(Left(CStr(InputCurveTenorsAndRates(i, 1)), Len(InputCurveTenorsAndRates(i, 1)) - 1)) / 52 | |
If UCase(Right(CStr(InputCurveTenorsAndRates(i, 1)), 1)) = "D" Then InputCurveTenorsAndRates(i, 1) = CDbl(Left(CStr(InputCurveTenorsAndRates(i, 1)), Len(InputCurveTenorsAndRates(i, 1)) - 1)) / 365 | |
If FromCurveType(i, 1) = nFut Then | |
InputCurveTenorsAndRates(i, 1) = (n_CDate(InputCurveTenorsAndRates(i, 1)) - Date) / 365 | |
InputCurveTenorsAndRates(i, 2) = (100 - InputCurveTenorsAndRates(i, 2)) / 100 | |
End If | |
End If | |
Next | |
'process input to DF | |
DFCurve = InputCurveTenorsAndRates | |
For i = 1 To UBound(DFCurve) | |
Select Case FromCurveType(i, 1) | |
Case nPar | |
If i = 1 Then | |
DFCurve(1, 2) = 1 / (1 + InputCurveTenorsAndRates(1, 2)) ^ InputCurveTenorsAndRates(1, 1) | |
Else | |
par = InputCurveTenorsAndRates(i, 2) 'extract par | |
'j = n_Sum(n_EC(DFCurve, 2), 1, i - 1) 'sum of preceding discount factors | |
j = n_Sum(n_DotProduct(n_EC(DFCurve, 2), n_Insert(nRow, n_Diff(n_EC(DFCurve, 1)), 1, , DFCurve(1, 1))), 1, i - 1) 'sum of preceding discount factors | |
DFCurve(i, 2) = (1 - par * j) / (1 + par) 'df(x) = (1-par(x)*sum(df,1,x-1))/(1+par(x)) | |
End If | |
Case nFwd, nFut 'needs work | |
If i = 1 Then | |
DFCurve(1, 2) = (1 / (1 + InputCurveTenorsAndRates(1, 2) * FwdDayCountBasisNumerators(i) / FwdDayCountBasisDenominator)) ^ InputCurveTenorsAndRates(1, 1) | |
Else | |
DFCurve(i, 2) = DFCurve(i - 1, 2) * (1 / (1 + InputCurveTenorsAndRates(i, 2) * FwdDayCountBasisNumerators(i) / FwdDayCountBasisDenominator)) ^ (InputCurveTenorsAndRates(i, 1) - InputCurveTenorsAndRates(i - 1, 1)) | |
End If | |
Case nZCB | |
DFCurve(i, 2) = 1 / ((1 + InputCurveTenorsAndRates(i, 2)) ^ InputCurveTenorsAndRates(i, 1)) | |
End Select | |
Next i | |
'process output | |
output = DFCurve ' initialize | |
Select Case ToCurveType | |
Case nPar | |
output(1, 2) = 1 / DFCurve(1, 2) ^ (1 / DFCurve(1, 1)) - 1 | |
For i = 2 To UBound(DFCurve) | |
output(i, 2) = n_PriceIRS(n_RateCurve(DFCurve, nDF, nFwd), i) | |
Next | |
Case nFwd | |
If IsArray(FwdDayCountBasisNumerators) Then 'adjust for daycounts | |
output(1, 2) = (1 / DFCurve(1, 2) - 1) * (FwdDayCountBasisDenominator / FwdDayCountBasisNumerators(1, 1)) | |
For i = 2 To UBound(DFCurve) | |
output(i, 2) = (DFCurve(i - 1, 2) / DFCurve(i, 2) - 1) * (FwdDayCountBasisDenominator / FwdDayCountBasisNumerators(i, 1)) | |
Next | |
Else | |
output(1, 2) = 1 / DFCurve(1, 2) ^ (1 / DFCurve(1, 1)) - 1 | |
For i = 2 To UBound(DFCurve) | |
output(i, 2) = (DFCurve(i - 1, 2) / DFCurve(i, 2)) ^ (1 / ((DFCurve(i, 1) - DFCurve(i - 1, 1)))) - 1 | |
Next | |
End If | |
Case nZCB | |
For i = 1 To UBound(DFCurve) | |
output(i, 2) = (1 / DFCurve(i, 2)) ^ (1 / DFCurve(i, 1)) - 1 | |
Next | |
Case nFut | |
Err.Raise (1) 'needs work | |
End Select | |
n_RateCurve = output | |
End Function | |
'----------Statistical Utilities----------- | |
Function n_AutoCorr(data, MaxLength As Integer, Optional VectorOfSignificants) | |
Dim i, output, temp | |
output = n_Array(MaxLength, 1) 'add the placeholder first column | |
For i = 1 To UBound(data, 2) | |
temp = n_Lag(n_Extract(nCol, data, i), MaxLength) | |
temp = n_Insert(nRow, n_Corr(temp), -1) 'we dont need the correlation of lag 0 to itself, its 1 obvi | |
output = n_Join(output, n_Extract(nCol, temp, 1), True) | |
Next i | |
output = n_Insert(nCol, output, -1) 'remove the placeholder first column | |
n_AutoCorr = output | |
End Function | |
Function n_AutoRegress(data, MaxLength As Integer, Optional VectorOfSignificants) | |
Dim i, output, temp | |
output = n_Array(MaxLength, 1) 'add the placeholder first column | |
For i = 1 To UBound(data, 2) | |
temp = n_Lag(n_Extract(nCol, data, i), MaxLength) | |
temp = n_Insert(nRow, n_Corr(temp), -1) 'we dont need the correlation of lag 0 to itself, its 1 obvi | |
output = n_Join(output, n_Extract(nCol, temp, 1), True) | |
Next i | |
output = n_Insert(nCol, output, -1) 'remove the placeholder first column | |
n_AutoRegress = output | |
End Function | |
Function n_Remove_AutoRegress(ByVal x, MaxLag As Integer) | |
Dim lagx | |
lagx = n_Lag(x, MaxLag) | |
n_Remove_AutoRegress = n_Regress(n_Extract(nCol, lagx, 1), n_Insert(nCol, lagx, -1), PValues) 'dddddddddddddddddddddddddddddd | |
End Function | |
Function n_Granger(ByVal x, ByVal y, MaxLag As Integer) | |
Dim i, j, k, output | |
output = n_Array(MaxLag + 1, MaxLag + 1) | |
x = n_Lag(x, MaxLag) | |
y = n_Lag(y, MaxLag) | |
For i = 0 To MaxLag | |
For j = 0 To MaxLag | |
k = n_Regress(n_EC(x, i + 1), n_EC(y, j + 1), PValues) | |
output(i + 1, j + 1) = k(1, 2) | |
Next j | |
Next i | |
n_Granger = output | |
End Function | |
Function n_QR(ByVal a, ByRef Q, ByRef R) | |
'http://www.cs.cornell.edu/~bindel/class/cs6210-f09/lec18.pdf | |
Dim M, n, j, normx, s, u1, w, tau, Rsub, p1, p2 | |
'[m,n] = size(A); | |
M = UBound(a, 1) | |
n = UBound(a, 2) | |
'Q = eye(m); % Orthogonal transform so far | |
Q = n_Eye(CInt(M)) | |
'R = A; % Transformed matrix so far | |
R = a | |
'for j = 1:n | |
For j = 1 To n - 1 | |
'% -- Find H = I-tau*w*w' to put zeros below R(j,j) | |
'normx = norm(R(j:end,j)); | |
Rsub = n_Extract(nRow, n_Extract(nCol, R, j), n_IntegerSequence(CInt(j), UBound(R, 1))) | |
normx = n_VectorLength(Rsub) | |
's = -sign(R(j,j)); | |
s = -Math.Sgn(R(j, j)) | |
'u1 = R(j,j) - s*normx; | |
u1 = R(j, j) - s * normx | |
'w = R(j:end,j)/u1; | |
'w = n_DotProduct(Rsub, n_Pow(u1, -1)) | |
w = n_DotProduct(Rsub, 1 / u1) | |
'w(1) = 1; | |
w(1, 1) = 1 | |
'tau = -s*u1/normx; | |
tau = -s * u1 / normx | |
'% -- R := HR, Q := QH | |
'R(j:end,:) = R(j:end,:)-(tau*w)*(w'*R(j:end,:)); | |
' p1 p2 | |
Rsub = n_Extract(nRow, R, n_IntegerSequence(CInt(j), UBound(R, 1))) | |
p2 = n_MMult(n_Transpose(w), Rsub) | |
p1 = n_DotProduct(tau, w) | |
Rsub = n_Add(Rsub, _ | |
n_MMult( _ | |
p1, _ | |
p2), -1) | |
If j > 1 Then R = n_Join(n_Extract(nRow, R, n_IntegerSequence(1, j - 1)), Rsub) Else R = Rsub | |
'Q(:,j:end) = Q(:,j:end)-(Q(:,j:end)*w)*(tau*w)'; | |
' p1 p2 | |
Rsub = n_Extract(nCol, Q, n_IntegerSequence(CInt(j), UBound(Q, 2))) | |
p1 = n_MMult(Rsub, w) | |
p2 = n_Transpose(n_DotProduct(tau, w)) | |
Rsub = n_Add(Rsub, _ | |
n_MMult( _ | |
p1, _ | |
p2), -1) | |
If j > 1 Then Q = n_Join(n_Extract(nCol, Q, n_IntegerSequence(1, j - 1)), Rsub, True) Else Q = Rsub | |
'end | |
Next j | |
'Q = n_FloatingPointZero(Q) | |
'R = n_FloatingPointZero(R) | |
'n_QR = n_MMult(Q, R) | |
n_QR = True | |
End Function | |
Function n_Eigenvector(ByRef M As Variant, Optional normalize As Boolean = True) As Variant | |
Dim sum | |
sum = n_Eigen(M, normalize) | |
n_Eigenvector = n_Extract(nCol, sum, n_IntegerSequence(2, UBound(M, 2) + 1)) | |
End Function | |
Function n_Eigenvalue(ByRef M As Variant, Optional normalize As Boolean = True) As Variant | |
n_Eigenvalue = n_Extract(nCol, n_Eigen(M, normalize), 1) | |
End Function | |
Function n_Eigen(ByRef M As Variant, Optional normalize As Boolean = True) As Variant | |
'http://www.freevbcode.com/ShowCode.asp?ID=9209 | |
Dim a() As Variant, Ematrix() As Double | |
Dim i As Long, j As Long, k As Long, iter As Long, p As Long | |
Dim den As Double, hold As Double, Sin_ As Double, num As Double | |
Dim Sin2 As Double, Cos2 As Double, Cos_ As Double, test As Double | |
Dim Tan2 As Double, Cot2 As Double, tmp As Double | |
Const eps As Double = 1E-16 | |
On Error GoTo EndProc | |
a = M | |
p = UBound(a, 1) | |
ReDim Ematrix(1 To p, 1 To p + 1) | |
For iter = 1 To 15 | |
'Orthogonalize pairs of columns in upper off diag | |
For j = 1 To p - 1 | |
For k = j + 1 To p | |
den = 0# | |
num = 0# | |
'Perform single plane rotation | |
For i = 1 To p | |
num = num + 2 * a(i, j) * a(i, k) ': numerator eq. 11 | |
den = den + (a(i, j) + a(i, k)) * (a(i, j) - a(i, k)) ': denominator eq. 11 | |
Next i | |
'Skip rotation if aij is zero and correct ordering | |
If Abs(num) < eps And den >= 0 Then Exit For | |
'Perform Rotation | |
If Abs(num) <= Abs(den) Then | |
Tan2 = Abs(num) / Abs(den) ': eq. 11 | |
Cos2 = 1 / Sqr(1 + Tan2 * Tan2) ': eq. 12 | |
Sin2 = Tan2 * Cos2 ': eq. 13 | |
Else | |
Cot2 = Abs(den) / Abs(num) ': eq. 16 | |
Sin2 = 1 / Sqr(1 + Cot2 * Cot2) ': eq. 17 | |
Cos2 = Cot2 * Sin2 ': eq. 18 | |
End If | |
Cos_ = Sqr((1 + Cos2) / 2) ': eq. 14/19 | |
Sin_ = Sin2 / (2 * Cos_) ': eq. 15/20 | |
If den < 0 Then | |
tmp = Cos_ | |
Cos_ = Sin_ ': table 21 | |
Sin_ = tmp | |
End If | |
Sin_ = Sgn(num) * Sin_ ': sign table 21 | |
'Rotate | |
For i = 1 To p | |
tmp = a(i, j) | |
a(i, j) = tmp * Cos_ + a(i, k) * Sin_ | |
a(i, k) = -tmp * Sin_ + a(i, k) * Cos_ | |
Next i | |
Next k | |
Next j | |
'Test for convergence | |
test = Application.SumSq(a) | |
If Abs(test - hold) < eps And iter > 10 Then Exit For | |
hold = test | |
Next iter | |
If iter = 16 Then MsgBox "JK Iteration has not converged." | |
'Compute eigenvalues/eigenvectors | |
For j = 1 To p | |
'Compute eigenvalues | |
For k = 1 To p | |
Ematrix(j, 1) = Ematrix(j, 1) + a(k, j) ^ 2 | |
Next k | |
Ematrix(j, 1) = Sqr(Ematrix(j, 1)) | |
'Normalize eigenvectors | |
If normalize Then | |
For i = 1 To p | |
If Ematrix(j, 1) <= 0 Then | |
Ematrix(i, j + 1) = 0 | |
Else | |
Ematrix(i, j + 1) = a(i, j) / Ematrix(j, 1) | |
End If | |
Next i | |
Else | |
For i = 1 To p | |
If Ematrix(j, 1) <= 0 Then | |
Ematrix(i, j + 1) = 0 | |
Else | |
Ematrix(i, j + 1) = a(i, j) '/ Ematrix(j, 1) | |
End If | |
Next i | |
End If | |
Next j | |
n_Eigen = Ematrix | |
Exit Function | |
EndProc: | |
MsgBox prompt:="Error in function n_Eigen!" & vbCr & vbCr & _ | |
"Error: " & Err.Description & ".", Buttons:=48, _ | |
Title:="Run time error!" | |
End Function | |
Function n_PCA(ByVal data, NumComponents As Integer, Optional firstdiff As Boolean = False, Optional ByRef PCApower) | |
Dim cM | |
If firstdiff Then data = n_Diff(data) | |
data = n_DeMean(data) | |
data = n_DeStdev(data) | |
cM = n_Cov(data) | |
n_PCA = n_Extract(nCol, n_Eigenvector(cM, False), n_IntegerSequence(1, NumComponents)) | |
PCApower = 0 | |
Dim eV, i | |
eV = n_Eigenvalue(cM) | |
For i = 1 To NumComponents | |
PCApower = PCApower + eV(i, 1) | |
Next i | |
PCApower = PCApower / n_Sum(eV) | |
End Function | |
Function n_PrinCompTransform(ByVal data, NumComponents As Integer, Optional fdiff As Boolean = False) | |
Dim PCAoutput, i, output, means, stdevs | |
If fdiff Then data = n_Diff(data, firstdiff) | |
means = n_Mean(data) | |
stdevs = n_Stdev(data) | |
data = n_DeMean(data) | |
data = n_DeStdev(data) | |
PCAoutput = n_PCA(data, NumComponents) | |
output = n_MMult(data, PCAoutput) | |
'means = n_Extract(nCol,means, n_IntegerSequence(1, NumComponents)) | |
'means = n_RepMat(means, UBound(output, 1), 1) | |
'stdevs = n_Extract(nCol,stdevs, n_IntegerSequence(1, NumComponents)) | |
'stdevs = n_RepMat(stdevs, UBound(output, 1), 1) | |
'output = n_DotProduct(output, stdevs) | |
'output = n_Add(output, means) | |
If fdiff Then | |
output = n_Join(n_Array(1, UBound(output, 2)), output) | |
output = n_CumSum(output) | |
End If | |
n_PrinCompTransform = output | |
End Function | |
Function n_PrinCompRegress(rawdata, NumComponents As Integer, Optional firstdiff As Boolean = False) | |
'http://en.wikipedia.org/wiki/Principal_component_regression | |
Dim PCRdata, data | |
If firstdiff Then data = n_Diff(rawdata) Else data = rawdata | |
PCRdata = n_PrinCompTransform(data, NumComponents) | |
n_PrinCompRegress = n_Regress(data, PCRdata) | |
End Function | |
Function n_Hist(ByVal V, Optional ByVal NumBucketsOrArrayOfBuckets, Optional ByVal SpecifyLowestBucket, Optional ByVal SpecifyHighestBucket, Optional ByVal SpecifyBucketWidth) | |
Dim output, i, j | |
If IsArray(NumBucketsOrArrayOfBuckets) Then | |
NumBucketsOrArrayOfBuckets = n_Ensure2DArray(n_Ensure1DArray(NumBucketsOrArrayOfBuckets)) | |
output = n_Join(n_Append(nRow, NumBucketsOrArrayOfBuckets, -1), n_Insert(nCol, NumBucketsOrArrayOfBuckets, -1), True) | |
Else | |
Dim lo, hi | |
If Not IsNumeric(SpecifyLowestBucket) Then lo = min(V) Else lo = SpecifyLowestBucket | |
If Not IsNumeric(SpecifyHighestBucket) Then hi = max(V) Else hi = SpecifyHighestBucket | |
If IsNumeric(SpecifyBucketWidth) And CDbl(SpecifyBucketWidth) <> 0 Then | |
hi = lo + (Int((hi - lo) / SpecifyBucketWidth)) * SpecifyBucketWidth | |
NumBucketsOrArrayOfBuckets = Int((hi - lo) / SpecifyBucketWidth) | |
End If | |
output = n_Array(CInt(NumBucketsOrArrayOfBuckets), 2) | |
For i = 1 To NumBucketsOrArrayOfBuckets | |
output(i, 1) = lo + (i - 1) * (hi - lo) / NumBucketsOrArrayOfBuckets | |
output(i, 2) = lo + (i) * (hi - lo) / NumBucketsOrArrayOfBuckets | |
Next | |
End If | |
'expand borders if not covered by low/hi buckets | |
If output(1, 1) <> min(V) Then | |
output = n_Insert(nCol, output, 1) | |
output(1, 1) = min(V) | |
output(1, 2) = output(2, 1) | |
End If | |
If output(UBound(output, 1), 2) <> max(V) Then | |
output = n_Append(nRow, output) | |
output(UBound(output, 1), 2) = max(V) | |
output(UBound(output, 1), 1) = output(UBound(output, 1) - 1, 2) | |
End If | |
'now count frequencies | |
output = n_Append(nCol, output) | |
For Each j In V | |
For i = 1 To UBound(output, 1) | |
If IsEmpty(output(i, 3)) Then output(i, 3) = 0 | |
If j <= output(i, 2) Then | |
output(i, 3) = output(i, 3) + 1 | |
Exit For | |
End If | |
Next i | |
Next j | |
j = n_Sum(output) | |
For i = 1 To UBound(output, 1) | |
output(i, 3) = output(i, 3) / j(1, 3) | |
Next i | |
n_Hist = output | |
End Function | |
Function n_ANOVA(ParamArray DataGroups() As Variant) | |
'returns p value of anova | |
'http://web.mst.edu/~psyworld/anovaexample.htm | |
'test with Call n_Anova(Array(6, 8, 4, 5, 3, 4), Array(8, 12, 9, 11, 6, 8), Array(13, 9, 11, 8, 7, 12)) | |
Dim i, j, k, l, M, SSTotal, SSamong, SSwithin | |
j = 0 'calculate SStotal | |
k = 0 'calculate SStotal | |
l = 0 'calculate SStotal | |
M = 0 'calculate SSAmong | |
For Each i In DataGroups | |
j = j + WorksheetFunction.SumSq(i) | |
k = k + WorksheetFunction.sum(i) | |
l = l + UBound(i) | |
M = M + (WorksheetFunction.sum(i) ^ 2) / UBound(i) | |
Next i | |
SSTotal = j - (k ^ 2) / l | |
SSamong = M - (k ^ 2) / l | |
SSwithin = SSTotal - SSamong | |
i = UBound(DataGroups) 'deg freedom between. supposed to -1 but ParamArray is base 0 so -1+1=0 | |
j = l - UBound(DataGroups) - 1 'deg freedom within. ParamArray base 0 so -1 on top of that | |
n_ANOVA = WorksheetFunction.FDist((SSamong / i) / (SSwithin / j), i, j) | |
End Function | |
Function n_Regress(y, x, Optional outputtype As n_Regress_Enum = coeffs, Optional RegressWithConstant As Boolean = True) | |
'x=nxp array, y is at least a nx1 2-dimensional array, but you can also regress y = nxm array and x = nxp array | |
Dim output, i, finaloutput | |
Select Case outputtype | |
Case coeffs | |
If UBound(y, 2) > 1 Then | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, 1), x, RegressWithConstant, False) | |
finaloutput = n_FlipLR(n_Ensure2DArray(output, True)) | |
For i = 2 To UBound(y, 2) | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, i), x, RegressWithConstant, False) | |
finaloutput = n_Join(finaloutput, n_FlipLR(n_Ensure2DArray(output, True))) | |
Next | |
Else | |
output = Application.WorksheetFunction.LinEst(y, x, RegressWithConstant, False) | |
finaloutput = n_FlipLR(n_Ensure2DArray(output, True)) | |
End If | |
Case CoeffsStdErrors | |
If UBound(y, 2) > 1 Then | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, 1), x, RegressWithConstant, True) | |
output = n_ER(output, 2) | |
finaloutput = n_FlipLR(n_Ensure2DArray(output, True)) | |
For i = 2 To UBound(y, 2) | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, i), x, RegressWithConstant, True) | |
output = n_ER(output, 2) | |
finaloutput = n_Join(finaloutput, n_FlipLR(n_Ensure2DArray(output, True))) | |
Next | |
Else | |
output = Application.WorksheetFunction.LinEst(y, x, RegressWithConstant, True) | |
output = n_ER(output, 2) | |
finaloutput = n_FlipLR(n_Ensure2DArray(output, True)) | |
End If | |
Case PValues | |
Dim pvaltemp1, pvaltemp2 | |
pvaltemp1 = n_Regress(y, x, coeffs, RegressWithConstant) | |
pvaltemp2 = n_Regress(y, x, CoeffsStdErrors, RegressWithConstant) | |
finaloutput = n_DotProduct(pvaltemp1, n_Pow(pvaltemp2, -1)) | |
For i = 1 To UBound(finaloutput, 2) | |
finaloutput(1, i) = n_Pval(finaloutput(1, i), UBound(x) - 1) | |
Next i | |
Case Else | |
'all the other stats | |
Dim col, row | |
col = 1 | |
row = 3 | |
If outputtype = YStdErrors Or outputtype = degf Or outputtype = SumSquaresResidual Then col = 2 | |
If outputtype = FStat Or outputtype = degf Then row = 4 | |
If outputtype = SumSquaresResidual Or outputtype = SumSquaresRegression Then row = 5 | |
If UBound(y, 2) > 1 Then | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, 1), x, RegressWithConstant, True) | |
finaloutput = n_Array(UBound(y, 2), 1, output(row, col)) | |
For i = 2 To UBound(y, 2) | |
output = Application.WorksheetFunction.LinEst(n_Extract(nCol, y, i), x, RegressWithConstant, True) | |
finaloutput(i, 1) = output(row, col) | |
Next | |
Else | |
output = Application.WorksheetFunction.LinEst(y, x, RegressWithConstant, True) | |
finaloutput = output(row, col) | |
End If | |
End Select | |
n_Regress = finaloutput | |
End Function | |
Function n_Pval(ByVal tstat, Optional degf = 99999, Optional TwoTail As Boolean = True) | |
If IsArray(tstat) Then | |
Dim i, j, output | |
tstat = n_Ensure2DArray(tstat) | |
output = n_Array(tstat) | |
For i = 1 To UBound(tstat, 1) | |
For j = 1 To UBound(tstat, 2) | |
If TwoTail Then | |
output(i, j) = WorksheetFunction.TDist(Abs(tstat(i, j)), degf, 1) | |
Else | |
If tstat < 0 Then output(i, j) = WorksheetFunction.TDist(Abs(tstat(i, j)), degf, 1) Else output(i, j) = 1 - WorksheetFunction.TDist(tstat(i, j), degf, 1) | |
End If | |
Next j | |
Next i | |
n_Pval = output | |
Else | |
If TwoTail Then | |
n_Pval = WorksheetFunction.TDist(Abs(tstat), degf, 1) | |
Else | |
If tstat < 0 Then n_Pval = WorksheetFunction.TDist(Abs(tstat), degf, 1) Else n_Pval = 1 - WorksheetFunction.TDist(tstat, degf, 1) | |
End If | |
End If | |
End Function | |
Function n_Residuals(y, x, Optional RegressWithConstant As Boolean = True) | |
Dim NRcoeffs, output | |
NRcoeffs = n_Transpose(n_Regress(y, x, coeffs, RegressWithConstant)) 'make sure its column vector of coeffs... | |
If RegressWithConstant Then | |
output = n_MMult(x, n_Insert(NRcoeffs, -1)) | |
output = n_Add(output, NRcoeffs(1, 1)) | |
Else 'no constant term in NRcoeffs | |
output = n_MMult(x, NRcoeffs) | |
End If | |
n_Residuals = n_Add(y, output, -1) | |
End Function | |
Function n_DickeyFuller(ByVal V, Optional confidencelevel As Double = 0) | |
Dim dV, c, Cstderr, DFTable | |
dV = n_Diff(V) | |
c = n_Regress(dV, n_Append(nRow, V, -1), coeffs) | |
Cstderr = n_Regress(dV, n_Append(nRow, V, -1), CoeffsStdErrors) | |
c = c(1, 2) | |
Cstderr = Cstderr(1, 2) | |
DFTable = n_BuildSurface(Array(25, 50, 100, 250, 500, 10000), _ | |
Array(0.01, 0.025, 0.05, 0.1, 0.9, 0.95, 0.975, 0.99), _ | |
n_Join(Array(-4.38, -3.95, -3.6, -3.24, -1.14, -0.8, -0.5, -0.15), _ | |
n_Join(Array(-4.15, -3.8, -3.5, -3.18, -1.19, -0.87, -0.58, -0.24), _ | |
n_Join(Array(-4.04, -3.73, -3.45, -3.15, -1.22, -0.9, -0.62, -0.28), _ | |
n_Join(Array(-3.99, -3.69, -3.43, -3.13, -1.23, -0.92, -0.64, -0.31), _ | |
n_Join(Array(-3.98, -3.68, -3.42, -3.13, -1.24, -0.93, -0.65, -0.32), _ | |
Array(-3.96, -3.66, -3.41, -3.12, -1.25, -0.94, -0.66, -0.33) _ | |
)))))) | |
'n_DickeyFuller = WorksheetFunction.TDist(Abs(C / Cstderr), UBound(V) - 1, 2) | |
'n_DickeyFuller = n_ExtractFromSurface(DFTable,Ubound(V)-1, | |
If confidencelevel <> 0 Then n_DickeyFuller = (n_DickeyFuller < confidencelevel) | |
End Function | |
'------------------------------------------------------------------------------------------------------------------------ | |
'---------------------------------------------------spreadsheet utilities------------------------------------------------ | |
'------------------------------------------------------------------------------------------------------------------------ | |
Public Function n_Interpolate(ByVal startnum, ByVal endnum, ByVal startTime, ByVal endTime, ByVal myTime, Optional loglinearinterpolation As Boolean = False) | |
If loglinearinterpolation Then | |
n_Interpolate = Exp((((Log(endnum) - Log(startnum)) / (endTime - startTime)) * (myTime - startTime)) + Log(startnum)) | |
Else | |
n_Interpolate = (((endnum - startnum) / (endTime - startTime)) * (myTime - startTime)) + startnum | |
End If | |
End Function | |
Function n_FormatColors() | |
Selection.Interior.Pattern = xlSolid | |
Select Case Selection.Interior.ColorIndex | |
Case xlNone, -4105 | |
Selection.Interior.ColorIndex = 36 'light yellow | |
Case 36 | |
Selection.Interior.ColorIndex = 35 'light green | |
Case 35 | |
Selection.Interior.ColorIndex = 2 'pure white | |
Case 2 | |
Selection.Interior.ColorIndex = xlNone 'none | |
End Select | |
End Function | |
Function n_FormatRangeAsPercent(theRange, Optional decimalplace As Integer = 2) | |
Dim sFRAPstring, i | |
If decimalplace > 0 Then | |
sFRAPstring = "." | |
For i = 1 To decimalplace | |
sFRAPstring = sFRAPstring & "0" | |
Next i | |
Else | |
sFRAPstring = "" | |
End If | |
theRange.NumberFormat = "0" & sFRAPstring & "%" | |
End Function | |
Function n_FormatIncreaseDecimalPlace() | |
If Left(Selection.NumberFormat, 1) = "$" Then | |
Select Case Selection.NumberFormat | |
Case "$#,##0_);[Red]($#,##0)" | |
Selection.NumberFormat = "$#,##0.0_);[Red]($#,##0.0)" | |
Case "$#,##0.0_);[Red]($#,##0.0)" | |
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" | |
Case "$#,##0.00_);[Red]($#,##0.00)" | |
Selection.NumberFormat = "$#,##0.000_);[Red]($#,##0.000)" | |
Case "$#,##0.000_);[Red]($#,##0.000)" | |
Selection.NumberFormat = "$#,##0.0000_);[Red]($#,##0.0000)" | |
Case "$#,##0.0000_);[Red]($#,##0.0000)" | |
Selection.NumberFormat = "$#,##0_);[Red]($#,##0)" | |
End Select | |
Else | |
If Right(Selection.NumberFormat, 1) = "%" Or Right(Selection.NumberFormat, 4) = " bp""" Then | |
Select Case Selection.NumberFormat | |
Case "0%" | |
Call n_FormatBasisPoints(Selection, False) | |
Selection.NumberFormat = "0.0%" | |
Case "0.0%" | |
Call n_FormatBasisPoints(Selection, False) | |
Selection.NumberFormat = "0.00%" | |
Case "0.00%" | |
Call n_FormatBasisPoints(Selection, False) | |
Selection.NumberFormat = "0.000%" | |
Case "0.000%" | |
Call n_FormatBasisPoints(Selection, False) | |
Selection.NumberFormat = "0.0000%" | |
Case "0.0000%" | |
Call n_FormatBasisPoints(Selection, True) | |
Selection.NumberFormat = "#,##0""bp"";[Red](#,##0)"" bp""" | |
Case "#,##0""bp"";[Red](#,##0)"" bp""" | |
Call n_FormatBasisPoints(Selection, True) | |
Selection.NumberFormat = "#,##0.0""bp"";[Red](#,##0.0)"" bp""" | |
Case "#,##0.0""bp"";[Red](#,##0.0)"" bp""" | |
Call n_FormatBasisPoints(Selection, True) | |
Selection.NumberFormat = "#,##0.00""bp"";[Red](#,##0.00)"" bp""" | |
Case "#,##0.00""bp"";[Red](#,##0.00)"" bp""" | |
Call n_FormatBasisPoints(Selection, False) | |
Selection.NumberFormat = "0%" | |
End Select | |
Else | |
If Not IsNumeric(Selection.NumberFormat) Then Selection.NumberFormat = "0.00" Else Selection.NumberFormat = Selection.NumberFormat & "0" | |
End If | |
End If | |
End Function | |
Private Function n_FormatBasisPoints(theselection, Optional DisplayInBasisPoints As Boolean = False) | |
Dim a | |
If DisplayInBasisPoints Then | |
For Each a In Selection | |
If Right(a.Formula, 7) <> ")*10000" Then | |
If IsNumeric(Right(a.Formula, Len(a.Formula) - 1)) Then a.Formula = Right(a.Formula, Len(a.Formula) - 1) | |
a.Formula = "=(" & a.Formula & ")*10000" | |
End If | |
Next | |
Else | |
For Each a In Selection | |
If Right(a.Formula, 7) = ")*10000" Then a.Formula = Left(a.Formula, Len(a.Formula) - 6) | |
If Left(a.Formula, 2) = "=(" And Right(a.Formula, 1) = ")" Then a.Formula = "=" & Mid(a.Formula, 3, Len(a.Formula) - 3) | |
Next | |
End If | |
End Function | |
Function n_FormatDecreaseDecimalPlace() | |
If Left(Selection.NumberFormat, 1) = "$" Then | |
Select Case Selection.NumberFormat | |
Case "$#,##0.0_);[Red]($#,##0.0)" | |
Selection.NumberFormat = "$#,##0);[Red]($#,##0)" | |
Case "$#,##0.00_);[Red]($#,##0.00)" | |
Selection.NumberFormat = "$#,##0.0_);[Red]($#,##0.0)" | |
Case "$#,##0.000_);[Red]($#,##0.000)" | |
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)" | |
Case "$#,##0.0000_);[Red]($#,##0.0000)" | |
Selection.NumberFormat = "$#,##0.000_);[Red]($#,##0.000)" | |
Case "$#,##0_);[Red]($#,##0)" | |
Selection.NumberFormat = "$#,##0.0000_);[Red]($#,##0.0000)" | |
End Select | |
Else | |
If Right(Selection.NumberFormat, 1) = "%" Or Right(Selection.NumberFormat, 4) = " bp""" Then | |
Select Case Selection.NumberFormat | |
Case "0.00%" | |
Selection.NumberFormat = "0.0%" | |
Case "0.000%" | |
Selection.NumberFormat = "0.00%" | |
Case "0.0000%" | |
Selection.NumberFormat = "0.000%" | |
Case "#,##0""bp"";[Red](#,##0)"" bp""" | |
Selection.NumberFormat = "0.0000%" | |
Case "#,##0.0""bp"";[Red](#,##0.0)"" bp""" | |
Selection.NumberFormat = "#,##0""bp"";[Red](#,##0)"" bp""" | |
Case "#,##0.00""bp"";[Red](#,##0.00)"" bp""" | |
Selection.NumberFormat = "#,##0.0""bp"";[Red](#,##0.0)"" bp""" | |
Case "0%" | |
Selection.NumberFormat = "#,##0.00""bp"";[Red](#,##0.00)"" bp""" | |
Case "0.0%" | |
Selection.NumberFormat = "0%" | |
End Select | |
Else | |
If Not IsNumeric(Selection.NumberFormat) Then Selection.NumberFormat = "0.00" Else Selection.NumberFormat = Left(Selection.NumberFormat, Len(Selection.NumberFormat) - 1) | |
End If | |
End If | |
End Function | |
Function n_ChartMakeBar() | |
If Selection.Count > 1 Then | |
Call n_MakeChartDefaults(Selection) | |
ActiveChart.charttype = xlColumnClustered | |
scron | |
End If | |
End Function | |
Function n_ChartMakeLine() | |
If Selection.Count > 1 Then | |
Call n_MakeChartDefaults(Selection) | |
ActiveChart.charttype = xlLine | |
If MsgBox("Apply series labels?", vbYesNo) = vbYes Then | |
Dim a | |
For Each a In ActiveChart.SeriesCollection | |
a.Points(a.Points.Count).ApplyDataLabels ShowSeriesName:=True | |
Next | |
End If | |
End If | |
End Function | |
Function n_ChartMakeScatter() | |
If Selection.Count > 1 Then | |
Call n_MakeChartDefaults(Selection) | |
ActiveChart.charttype = xlXYScatter | |
'If Application.Version > 11 Then ActiveChart.ApplyLayout (9) | |
End If | |
End Function | |
Function n_MakeChartDefaults(theselection) | |
scroff | |
Charts.Add | |
ActiveChart.HasTitle = True | |
ActiveChart.ChartTitle.Text = "Title" & vbNewLine & "The Subtitle" | |
ActiveChart.ChartTitle.Font.Name = "Franklin Gothic Book" | |
ActiveChart.ChartTitle.Font.Bold = True | |
ActiveChart.ChartTitle.Font.Size = 20 | |
ActiveChart.ChartTitle.Characters(Start:=7, Length:=13).Font.Italic = True | |
ActiveChart.ChartTitle.Characters(Start:=7, Length:=13).Font.Size = 8 | |
'ActiveChart.ChartTitle.Left = 7.084 | |
'ActiveChart.ChartTitle.top = 6 | |
ActiveChart.SetSourceData Source:=theselection | |
ActiveChart.location Where:=xlLocationAsObject, Name:=theselection.Parent.Name | |
ActiveChart.Axes(xlValue).MajorGridlines.Border.ColorIndex = 57 | |
ActiveChart.Axes(xlValue).MajorGridlines.Border.Weight = xlHairline | |
ActiveChart.Axes(xlValue).MajorGridlines.Border.LineStyle = xlDash | |
ActiveChart.Axes(xlCategory).TickLabelPosition = xlLow | |
ActiveChart.Axes(xlValue).TickLabelPosition = xlLow | |
ActiveChart.Legend.Position = xlBottom | |
With ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 1, ActiveChart.Parent.Height - 20, 100, 20) | |
With .TextFrame.Characters | |
.Text = "Source: Source" | |
.Font.Italic = True | |
.Font.Size = 8 | |
End With | |
.top = ActiveChart.Parent.Height - 20 | |
End With | |
If ActiveChart.SeriesCollection.Count > 2 Then ActiveChart.SeriesCollection(3).Border.ColorIndex = 10 'gets rid of yellow color | |
Dim i | |
For i = 1 To ActiveChart.SeriesCollection.Count 'quickly remmove all markers | |
If ActiveChart.charttype = xlLine Then | |
ActiveChart.SeriesCollection(i).MarkerStyle = xlNone | |
If i = 2 Then ActiveChart.SeriesCollection(i).Border.ColorIndex = 12 | |
If i = 3 Then ActiveChart.SeriesCollection(i).Border.ColorIndex = 10 | |
If i = 4 Then ActiveChart.SeriesCollection(i).Border.ColorIndex = 13 | |
End If | |
Next i | |
ActiveChart.Legend.Position = xlBottom | |
ActiveChart.PlotArea.Interior.ColorIndex = xlNone | |
scron | |
End Function | |
Function n_ChartMake3D() | |
If Selection.Count > 1 Then | |
Call n_MakeChartDefaults(Selection) | |
ActiveChart.charttype = xlSurface | |
End If | |
End Function | |
Function n_ChartRotateSurfaceUp() | |
On Error GoTo errhandl | |
If n_Is3DChart(ActiveChart.charttype) Then | |
If ActiveChart.Elevation + 10 > 90 Then ActiveChart.Elevation = -90 Else ActiveChart.Elevation = ActiveChart.Elevation + 10 | |
End If | |
errhandl: | |
On Error GoTo 0 | |
End Function | |
Function n_ChartRotateSurfaceDown() | |
On Error GoTo errhandl | |
If n_Is3DChart(ActiveChart.charttype) Then | |
If ActiveChart.Elevation - 10 < -90 Then ActiveChart.Elevation = 90 Else ActiveChart.Elevation = ActiveChart.Elevation - 10 | |
On Error GoTo 0 | |
Exit Function | |
End If | |
errhandl: | |
On Error GoTo 0 | |
Call n_ChartMakeScatter | |
End Function | |
Function n_ChartRotateSurfaceLeft() | |
On Error GoTo errhandl | |
If n_Is3DChart(ActiveChart.charttype) Then | |
If ActiveChart.Rotation + 10 > 360 Then ActiveChart.Rotation = 0 Else ActiveChart.Rotation = ActiveChart.Rotation + 10 | |
End If | |
errhandl: | |
On Error GoTo 0 | |
End Function | |
Function n_ChartRotateSurfaceRight() | |
On Error GoTo errhandl | |
If n_Is3DChart(ActiveChart.charttype) Then | |
If ActiveChart.Rotation - 10 < 0 Then ActiveChart.Rotation = 360 Else ActiveChart.Rotation = ActiveChart.Rotation - 10 | |
End If | |
errhandl: | |
On Error GoTo 0 | |
End Function | |
Function n_Is3DChart(charttype) As Boolean | |
Select Case charttype | |
Case xlSurface, xl3DColumnClustered, xl3DArea, xl3DAreaStacked, xl3DAreaStacked100, xl3DBarClustered, xl3DBarStacked, xl3DBarStacked100, xl3DColumn, xl3DColumnClustered, xl3DColumnStacked, xl3DColumnStacked100, xl3DLine, xl3DPie, xl3DPieExploded, xlSurfaceWireframe, xlBubble3DEffect, xlCylinderCol | |
n_Is3DChart = True | |
Case Else | |
n_Is3DChart = False | |
End Select | |
End Function | |
Function n_ChartAlign2Axes() | |
On Error GoTo errhandl | |
If ActiveChart.SeriesCollection.Count > 1 Then | |
If n_Is3DChart(ActiveChart.charttype) Then Exit Function | |
On Error GoTo 0 | |
Dim a, i, j | |
i = "Enter in the series number separated by commas. Note you cannot have all series aligned on RHS." & vbNewLine & vbNewLine | |
For Each a In ActiveChart.SeriesCollection | |
j = j + 1 | |
If a.AxisGroup = xlPrimary Then i = i & j & "-" & a.Name & "(LHS)" & vbNewLine Else i = i & j & "-" & a.Name & "(RHS)" & vbNewLine | |
Next | |
i = InputBox(i, "Which series do you want to align on RHS?") | |
If i = "" Then Exit Function | |
i = Split(i, ",") | |
' If UBound(i) = 0 Then 'just one | |
' On Error Resume Next | |
' If ActiveChart.SeriesCollection(CInt(i(0))).AxisGroup = xlPrimary Then ActiveChart.SeriesCollection(CInt(i(0))).AxisGroup = xlSecondary | |
' On Error GoTo 0 | |
' Else 'multiple | |
For Each a In ActiveChart.SeriesCollection | |
a.AxisGroup = xlPrimary | |
a.MarkerStyle = xlNone | |
Next | |
For j = 1 To ActiveChart.SeriesCollection.Count | |
If n_WhereInArray(CStr(j), i) <> False Then | |
If ActiveChart.SeriesCollection(CInt(j)).AxisGroup = xlPrimary Then ActiveChart.SeriesCollection(CInt(j)).AxisGroup = xlSecondary | |
End If | |
Next j | |
' End If | |
'If ActiveChart.SeriesCollection(ActiveChart.SeriesCollection.Count).AxisGroup = xlPrimary Then ActiveChart.SeriesCollection(ActiveChart.SeriesCollection.Count).AxisGroup = xlSecondary | |
On Error Resume Next | |
ActiveChart.Axes(xlValue, xlSecondary).MaximumScaleIsAuto = True | |
ActiveChart.Axes(xlValue, xlPrimary).MaximumScaleIsAuto = True | |
ActiveChart.Axes(xlValue, xlSecondary).MinimumScaleIsAuto = True | |
ActiveChart.Axes(xlValue, xlPrimary).MinimumScaleIsAuto = True | |
On Error GoTo 0 | |
Dim maxPos, maxNeg, mu1, mu2 | |
For i = 1 To 2 | |
mu1 = ActiveChart.Axes(xlValue, xlPrimary).MajorUnit | |
mu2 = ActiveChart.Axes(xlValue, xlSecondary).MajorUnit | |
maxPos = CInt(WorksheetFunction.max(ActiveChart.Axes(xlValue, xlPrimary).MaximumScale / mu1, ActiveChart.Axes(xlValue, xlSecondary).MaximumScale / mu2)) | |
maxNeg = CInt(WorksheetFunction.min(ActiveChart.Axes(xlValue, xlPrimary).MinimumScale / mu1, ActiveChart.Axes(xlValue, xlSecondary).MinimumScale / mu2)) | |
ActiveChart.Axes(xlValue, xlPrimary).MaximumScale = ActiveChart.Axes(xlValue, xlPrimary).MajorUnit * maxPos | |
ActiveChart.Axes(xlValue, xlSecondary).MaximumScale = ActiveChart.Axes(xlValue, xlSecondary).MajorUnit * maxPos | |
ActiveChart.Axes(xlValue, xlPrimary).MinimumScale = ActiveChart.Axes(xlValue, xlPrimary).MajorUnit * maxNeg | |
ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = ActiveChart.Axes(xlValue, xlSecondary).MajorUnit * maxNeg | |
Next i | |
End If | |
Exit Function | |
errhandl: 'no chart in sight, default to inc decimal place | |
On Error GoTo 0 | |
Call n_FormatIncreaseDecimalPlace | |
End Function | |
Function n_ChartAddLine() | |
Dim a | |
On Error GoTo Quit | |
MsgBox ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale | |
If IsDate(CDate(ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale)) Then | |
a = CDate(InputBox("Min is " & CDate(ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale) & ". Max is " & CDate(ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale))) | |
Else | |
a = InputBox("Min is " & ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale & ". Max is " & ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale) | |
End If | |
a = (a - ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale) / (ActiveChart.Axes(xlCategory, xlPrimary).MaximumScale - ActiveChart.Axes(xlCategory, xlPrimary).MinimumScale) | |
With ActiveChart.Shapes.AddLine(ActiveChart.PlotArea.Left + ActiveChart.PlotArea.Width * a, ActiveChart.Axes(xlValue, xlPrimary).top, ActiveChart.PlotArea.Left + ActiveChart.PlotArea.Width * a, ActiveChart.Axes(xlValue, xlPrimary).top + ActiveChart.Axes(xlValue, xlPrimary).Height) | |
.Line.ForeColor.SchemeColor = 10 | |
.Line.Visible = msoTrue | |
.Line.Weight = 1.5 | |
.Line.Visible = msoTrue | |
.Line.Style = msoLineSingle | |
.Line.DashStyle = msoLineSquareDot | |
End With | |
Quit: | |
Set a = ActiveChart.Axes(xlCategory, xlPrimary) | |
On Error GoTo 0 | |
End Function | |
Function n_HardCode(RangeToHardCode As Range, Optional Direction As n_Direction_Enum = DirNone) | |
n_RangeEnd(RangeToHardCode, Direction).Value2 = n_RangeEnd(RangeToHardCode, Direction).Value2 | |
n_HardCode = True | |
End Function | |
Function n_LastCell(wspointer) As Range | |
'Find last cell by searching | |
Call n_AutoFilterOff(wspointer) | |
Dim LastRow&, LastCol% | |
On Error Resume Next | |
With wspointer | |
LastRow& = .Cells.Find(What:="*", _ | |
SearchDirection:=xlPrevious, _ | |
SearchOrder:=xlByRows).row | |
LastCol% = .Cells.Find(What:="*", _ | |
SearchDirection:=xlPrevious, _ | |
SearchOrder:=xlByColumns).Column | |
End With | |
Set n_LastCell = wspointer.Cells(LastRow&, LastCol%) | |
End Function | |
Function n_LastRow(Optional firstcell) As Double | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
Call n_AutoFilterOff(FirstCellToPasteIn.Parent) | |
If FirstCellToPasteIn.Offset(1, 0).Value = "" Then | |
n_LastRow = FirstCellToPasteIn.row | |
Else | |
n_LastRow = FirstCellToPasteIn.End(xlDown).row | |
End If | |
End Function | |
Function n_AutoFilterOff(wspointer) | |
If Application.Version >= 12 Then 'excel 2007 | |
If wspointer.AutoFilterMode = True Then wspointer.AutoFilter.ShowAllData | |
Else | |
wspointer.AutoFilterMode = False | |
End If | |
End Function | |
Function n_ClearWorksheet(wspointerOrSheetName, Optional sheetname As String = "") As Boolean | |
Dim thecurrentws | |
Set thecurrentws = ActiveSheet | |
n_ClearWorksheet = True | |
On Error GoTo noitisnt | |
If IsError(wspointerOrSheetName) Or IsEmpty(wspointerOrSheetName) Then GoTo noitisnt | |
If IsObject(wspointerOrSheetName) Then | |
wspointerOrSheetName.Parent.Activate | |
wspointerOrSheetName.Activate | |
Call n_AutoFilterOff(wspointerOrSheetName) | |
wspointerOrSheetName.Cells.ClearContents | |
If sheetname <> "" Then wspointerOrSheetName.Name = sheetname | |
Else | |
Sheets(wspointerOrSheetName).Parent.Activate | |
Sheets(wspointerOrSheetName).Activate | |
Call n_AutoFilterOff(Sheets(wspointerOrSheetName)) | |
Sheets(wspointerOrSheetName).Cells.ClearContents | |
If sheetname <> "" Then Sheets(wspointerOrSheetName).Name = sheetname | |
End If | |
thecurrentws.Parent.Activate | |
thecurrentws.Activate | |
Exit Function | |
noitisnt: | |
n_ClearWorksheet = False | |
Sheets.Add | |
If IsObject(wspointerOrSheetName) Or IsError(wspointerOrSheetName) Or IsEmpty(wspointerOrSheetName) Then | |
Set wspointerOrSheetName = ActiveSheet | |
If sheetname <> "" Then wspointerOrSheetName.Name = sheetname | |
Else | |
If sheetname <> "" Then Sheets(wspointerOrSheetName).Name = sheetname | |
End If | |
End Function | |
Function n_DeleteSheet(wspointerOrSheetName) As Boolean | |
On Error GoTo doesntexist | |
Application.DisplayAlerts = False | |
If IsObject(wspointerOrSheetName) Then | |
wspointerOrSheetName.Delete | |
Else | |
Sheets(wspointerOrSheetName).Delete | |
End If | |
Application.DisplayAlerts = True | |
n_DeleteSheet = True | |
doesntexist: | |
On Error GoTo 0 | |
n_DeleteSheet = False | |
End Function | |
Function n_DoesSheetExist(sheetname As String) As Boolean | |
Dim junk | |
On Error GoTo doesntexist | |
junk = Sheets(sheetname).Name | |
n_DoesSheetExist = True | |
On Error GoTo 0 | |
Exit Function | |
doesntexist: | |
n_DoesSheetExist = False | |
On Error GoTo 0 | |
End Function | |
Function n_FillEmptyRange(theRange As Range) As Boolean | |
Dim stor, i, j, temp | |
stor = theRange.Formula | |
For j = LBound(stor, 2) To UBound(stor, 2) | |
temp = "Warning : No Data" | |
For i = LBound(stor, 1) To UBound(stor, 1) | |
If stor(i, j) = "" Then stor(i, j) = temp Else temp = stor(i, j) | |
Next i | |
Next j | |
theRange.Formula = stor | |
n_FillEmptyRange = True | |
End Function | |
Function n_FillDown(thecell As Range, Optional ToRight As Boolean = False) As Boolean | |
If ToRight Then n_RangeEnd(thecell, DirDownRight).FillDown Else n_RangeEnd(thecell, DirDown).FillDown | |
n_FillDown = True | |
End Function | |
Function n_RangeClearContents(firstcell As Range, Optional Direction As n_Direction_Enum = DirNone, Optional maxcolumns As Double = 0, Optional maxrows As Double = 0) As Boolean | |
If firstcell.Value2 = "" Then Exit Function | |
n_RangeEnd(firstcell, Direction, maxcolumns, maxrows).ClearContents | |
n_RangeClearContents = True | |
End Function | |
Function n_RangeAutoFit(firstcell) | |
n_RangeEnd(firstcell, DirRight).Columns.AutoFit | |
End Function | |
Function n_BlankIfNA(something) | |
n_BlankIfNA = n_IfNA(something) | |
End Function | |
Public Function n_IfNA(something, Optional ReplaceWith As String = "") | |
If WorksheetFunction.IsErr(something) Or WorksheetFunction.IsNA(something) Then | |
n_IfNA = ReplaceWith | |
Else | |
n_IfNA = something | |
End If | |
End Function | |
'------------------------------------------------------------------------------------------------------------------------ | |
'---------------------------------------------------file i/o utilities------------------------------------------------ | |
'------------------------------------------------------------------------------------------------------------------------ | |
Function n_EmailRange(theRange As Range, itemto As String, itemsubject As String, Optional autosend As Boolean = False) | |
' Select the range of cells on the active worksheet. | |
theRange.Parent.Activate | |
theRange.Select | |
If Not autosend Then theRange.Parent.Parent.EnvelopeVisible = True | |
With theRange.Parent.MailEnvelope | |
.Item.To = itemto | |
.Item.Subject = itemsubject | |
If autosend Then .Item.Send | |
End With | |
End Function | |
Function n_EmailSheet(wspointer As Worksheet, FileName As String, ToEmail As String, ToCC As String, ToSubject As String, Optional autosend As Boolean = False, Optional hardcode As Boolean = True, Optional EmailBody = "") | |
Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook, Destwb As Workbook, TempFilePath As String, TempFileName As String, OutApp As Object, OutMail As Object | |
scroff | |
Set Sourcewb = ActiveWorkbook | |
wspointer.Copy | |
Set Destwb = ActiveWorkbook | |
With Destwb | |
If Val(Application.Version) < 12 Then | |
FileExtStr = ".xls": FileFormatNum = -4143 | |
Else | |
'We exit the sub when your answer is NO in the security dialog that you only see when you copy a sheet from a xlsm file with macro's disabled. | |
If Sourcewb.Name = .Name Then | |
scron | |
Exit Function | |
Else | |
Select Case Sourcewb.FileFormat | |
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 | |
Case 52: | |
If .HasVBProject Then | |
FileExtStr = ".xlsm": FileFormatNum = 52 | |
Else | |
FileExtStr = ".xlsx": FileFormatNum = 51 | |
End If | |
Case 56: FileExtStr = ".xls": FileFormatNum = 56 | |
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 | |
End Select | |
End If | |
End If | |
End With | |
If hardcode Then Destwb.Sheets(1).UsedRange.Value = Destwb.Sheets(1).UsedRange.Value 'Change all cells in the worksheet to values if you want | |
'Save the new workbook/Mail it/Delete it | |
TempFilePath = Environ$("temp") & "\" | |
Set OutApp = CreateObject("Outlook.Application") | |
OutApp.Session.Logon | |
Set OutMail = OutApp.CreateItem(0) | |
Destwb.SaveAs TempFilePath & FileName & FileExtStr, FileFormat:=FileFormatNum | |
On Error Resume Next | |
OutMail.To = ToEmail | |
OutMail.CC = ToCC | |
OutMail.BCC = "" | |
OutMail.Subject = ToSubject | |
OutMail.Body = EmailBody | |
OutMail.Attachments.Add Destwb.FullName 'You can add other files also like this: .Attachments.Add ("C:\test.txt") | |
If autosend Then .Send | |
On Error GoTo 0 | |
Destwb.Close SaveChanges:=False | |
Kill TempFilePath & FileName & FileExtStr 'Delete the file you have sent | |
Set OutMail = Nothing | |
Set OutApp = Nothing | |
scron | |
End Function | |
Function n_AccessOpenWorkbook(WorkbookPointer, FileWeAreLookingFor As String, Optional TextToCheck As String = "", Optional CellToCheck As String = "A1", Optional SheetToCheck = 1) | |
Dim variabl, resp, cancel As Boolean, aowc | |
Do | |
variabl = "" | |
cancel = True | |
aowc = 1 | |
For Each resp In Workbooks | |
variabl = variabl & aowc & "-" & resp.Name & ". " & vbNewLine | |
aowc = aowc + 1 | |
Next resp | |
variabl = InputBox(variabl, "If you have this file (" & FileWeAreLookingFor & ") open, please input its index number accordingly. If it is not open, you can leave the box blank and press cancel to open it up. " & vbNewLine) | |
If variabl = variabl > aowc - 1 Or variabl < 0 Then cancel = False | |
Loop While cancel = False | |
If variabl = "" Then | |
resp = MsgBox("Cancelled. Do you want to look for and open the file instead?", vbYesNo) | |
If resp = vbYes Then | |
n_AccessOpenWorkbook = n_GetFileCheckFileAndOpen(WorkbookPointer, "Find the file " & FileWeAreLookingFor, TextToCheck, CellToCheck, SheetToCheck) | |
Exit Function | |
Else | |
n_AccessOpenWorkbook = False | |
End If | |
Exit Function | |
Else | |
Set WorkbookPointer = Workbooks(CInt(variabl)) | |
n_AccessOpenWorkbook = True | |
End If | |
End Function | |
Function n_GetFolder(Optional strPath As String = "C:\") | |
Dim fldr As FileDialog | |
Dim sItem As String | |
n_GetFolder = False | |
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) | |
'If fldr = False Then Exit Function | |
With fldr | |
.Title = "Select a Folder" | |
.AllowMultiSelect = False | |
.InitialFileName = strPath | |
If .Show <> -1 Then GoTo NextCode | |
sItem = .SelectedItems(1) | |
End With | |
NextCode: | |
n_GetFolder = sItem | |
Set fldr = Nothing | |
If n_GetFolder = "" Then n_GetFolder = False | |
End Function | |
Function n_FindDesktopPath() As String | |
n_FindDesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator | |
End Function | |
Function n_GetFileCheckFileAndOpen(WorkbookPointer, UserPrompt As String, Optional TextToCheck As String = "", Optional CellToCheck As String = "A1", Optional SheetToCheck = 1) | |
Dim filepath | |
Do | |
filepath = Application.GetOpenFilename(, , UserPrompt) | |
If filepath = False Then | |
n_GetFileCheckFileAndOpen = False | |
Exit Function | |
End If | |
filepath = n_CheckFileAndOpen(WorkbookPointer, CStr(filepath), TextToCheck, CellToCheck, SheetToCheck) | |
Loop While filepath = False | |
n_GetFileCheckFileAndOpen = filepath | |
End Function | |
Function n_CheckFileAndOpen(WorkbookPointer, filepath As String, Optional TextToCheck As String = "", Optional CellToCheck As String = "A1", Optional SheetToCheck = 1) | |
'if a given file from a filepath is open, activate it. | |
'if it is not, open it and check if it is the kind of file we want (secret check text supplied) | |
'if it is not, close it and return false | |
'if it is, open it and return true. | |
On Error GoTo notopen | |
Dim js() | |
js = Split(filepath, "\", , vbTextCompare) | |
Workbooks(js(UBound(js))).Activate | |
n_CheckFileAndOpen = True | |
On Error GoTo 0 | |
Exit Function | |
notopen: | |
Dim thefile As Workbook | |
Application.DisplayAlerts = False | |
Set thefile = Workbooks.Open(FileName:=filepath, UpdateLinks:=0, CorruptLoad:=xlRepairFile) | |
Application.DisplayAlerts = True | |
On Error GoTo failed | |
'Set thefile = Workbooks(Workbooks.Count) | |
thefile.Activate | |
thefile.Sheets(SheetToCheck).Select | |
thefile.Sheets(SheetToCheck).Range(CellToCheck).Select | |
If TextToCheck = "" Or thefile.Sheets(SheetToCheck).Range(CellToCheck).Value2 = TextToCheck Then | |
Set WorkbookPointer = thefile | |
n_CheckFileAndOpen = filepath | |
On Error GoTo 0 | |
Exit Function | |
End If | |
failed: | |
On Error GoTo 0 | |
n_CheckFileAndOpen = False | |
Application.ScreenUpdating = True | |
Dim result | |
result = MsgBox("This file failed the filecheck. It may not be the right file or the file's contents may be incomplete. Do you want me to leave the file open for you to investigate?", vbYesNo) | |
If result = vbNo Then thefile.Close | |
If result = vbYes Then Err.Raise (2) | |
End Function | |
Function n_SaveWorkbookAsNewFile(NewFileNameUnformatted As String, Optional FileType1forXLSor2forXLSXor3forXLSM As Integer = 1, Optional OpenOldFile As Boolean = False, Optional CloseNewFile As Boolean = False) As Boolean | |
Dim ActSheet As Worksheet, ActBook As Workbook, CurrentFile As String, NewFileType As String, NewFile, NewFileName As String | |
NewFileNameUnformatted = Replace(NewFileNameUnformatted, ":", "") | |
NewFileName = Replace(NewFileNameUnformatted, "/", "") | |
CurrentFile = ThisWorkbook.FullName | |
'for 2003 | |
NewFile = Application.GetSaveAsFilename(NewFileName & ".xls") | |
If NewFile <> "" And NewFile <> False Then | |
ActiveWorkbook.SaveAs (NewFile) | |
End If | |
Set ActBook = ActiveWorkbook | |
If OpenOldFile Then Workbooks.Open CurrentFile | |
'only in 2007 | |
' If FileType1forXLSor2forXLSXor3forXLSM = 1 Then NewFileType = "Excel Files 2003 (*.xls), *.xls," & "All files (*.*), *.*" | |
' If FileType1forXLSor2forXLSXor3forXLSM = 2 Then NewFileType = "Excel Files 2007 (*.xlsx), *.xlsx," & "All files (*.*), *.*" | |
' If FileType1forXLSor2forXLSXor3forXLSM = 3 Then NewFileType = "Excel 2007 Macro-enabled Files (*.xlsm), *.xlsm," & "All files (*.*), *.*" | |
' NewFile = Application.GetSaveAsFilename( _ | |
' InitialFileName:=NewFileName, _ | |
' fileFilter:=NewFileType) | |
' | |
' Select Case FileType1forXLSor2forXLSXor3forXLSM | |
' Case 1 | |
' If NewFile <> "" And NewFile <> False Then | |
' ActiveWorkbook.saveas Filename:=NewFile, _ | |
' FileFormat:=xlExcel8, _ | |
' Password:="", _ | |
' WriteResPassword:="", _ | |
' ReadOnlyRecommended:=False, _ | |
' CreateBackup:=False | |
' Set ActBook = ActiveWorkbook | |
' If OpenOldFile Then Workbooks.Open CurrentFile | |
' End If | |
' Case 2 | |
' If NewFile <> "" And NewFile <> False Then | |
' ActiveWorkbook.saveas Filename:=NewFile, _ | |
' FileFormat:=xlOpenXMLWorkbook, _ | |
' Password:="", _ | |
' WriteResPassword:="", _ | |
' ReadOnlyRecommended:=False, _ | |
' CreateBackup:=False | |
' Set ActBook = ActiveWorkbook | |
' If OpenOldFile Then Workbooks.Open CurrentFile | |
' End If | |
' Case Else | |
' If NewFile <> "" And NewFile <> False Then | |
' ActiveWorkbook.saveas Filename:=NewFile, _ | |
' FileFormat:=xlOpenXMLWorkbookMacroEnabled, _ | |
' Password:="", _ | |
' WriteResPassword:="", _ | |
' ReadOnlyRecommended:=False, _ | |
' CreateBackup:=False | |
' Set ActBook = ActiveWorkbook | |
' If OpenOldFile Then Workbooks.Open CurrentFile | |
' End If | |
' End Select | |
If CloseNewFile Then ActBook.Close Else ActBook.Activate | |
n_SaveWorkbookAsNewFile = True | |
End Function | |
Function n_Close(iWB) As Boolean | |
iWB.Activate | |
Dim junkwb As Workbook | |
Set junkwb = iWB | |
Application.DisplayAlerts = False | |
junkwb.Activate | |
junkwb.Close | |
Set junkwb = Nothing | |
Set iWB = Nothing | |
Application.DisplayAlerts = True | |
n_Close = True | |
End Function | |
Public Function n_DeleteFile(sFile) As Boolean | |
Dim FileOperation As SHFILEOPSTRUCT | |
Dim lReturn As Long | |
Dim sFileName As String | |
On Error GoTo someerror | |
Const FO_DELETE = &H3 | |
Const FOF_ALLOWUNDO = &H40 | |
Const FOF_NOCONFIRMATION = &H10 | |
With FileOperation | |
.wFunc = FO_DELETE | |
.pFrom = sFile | |
.fFlags = FOF_ALLOWUNDO | |
' OR if you want to suppress the "Do You want | |
' to delete the file" message, use | |
.fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION | |
End With | |
lReturn = SHFileOperation(FileOperation) | |
n_DeleteFile = True | |
Exit Function | |
someerror: | |
n_DeleteFile = False | |
End Function | |
'------------------------------------------------------------------------------------------------------------------------ | |
'------------------------------------------------------------------------------------------------------------------------ | |
'---------------------------------------------------core utilities--------------------------------------------------- | |
'------------------------------------------------------------------------------------------------------------------------ | |
'------------------------------------------------------------------------------------------------------------------------ | |
Sub scroff() | |
Application.ScreenUpdating = False | |
'Application.DisplayStatusBar = False | |
Application.StatusBar = False | |
Application.Calculation = xlCalculationManual | |
Application.EnableEvents = False | |
End Sub | |
Sub scron() | |
Application.ScreenUpdating = True | |
'Application.DisplayStatusBar = True | |
Application.EnableEvents = True | |
End Sub | |
Function n_P(firstcell, a, Optional NumRowsToPaste As Long = 0, Optional NumColsToPaste As Integer = 0) As Boolean | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
n_P = n_PasteValue(FirstCellToPasteIn, a, NumRowsToPaste, NumColsToPaste) | |
End Function | |
Function n_PasteValue(firstcell, a, Optional NumRowsToPaste As Long = 0, Optional NumColsToPaste As Integer = 0) As Boolean | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
'paste an array on a worksheet just by supplying the first cell. Can limit number of rows and cols to paste. | |
a = n_Ensure2DArray(a) 'makes it a column vector if 1 dimensional | |
If NumRowsToPaste = 0 Then NumRowsToPaste = UBound(a, 1) - LBound(a, 1) + 1 Else NumRowsToPaste = WorksheetFunction.min(NumRowsToPaste, UBound(a, 1)) | |
If NumColsToPaste = 0 Then NumColsToPaste = UBound(a, 2) - LBound(a, 2) + 1 Else NumColsToPaste = WorksheetFunction.min(NumColsToPaste, UBound(a, 2)) | |
FirstCellToPasteIn.Parent.Range(FirstCellToPasteIn.Address & ":" & FirstCellToPasteIn.Offset(NumRowsToPaste - 1, NumColsToPaste - 1).Address).Value2 = a | |
n_PasteValue = True | |
End Function | |
Function n_PasteFormula(firstcell, a, Optional NumRowsToPaste As Long = 0, Optional NumColsToPaste As Integer = 0) As Boolean | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
a = n_Ensure2DArray(a) | |
'paste an array on a worksheet just by supplying the first cell. Can limit number of rows and cols to paste. | |
If NumRowsToPaste = 0 Then NumRowsToPaste = UBound(a, 1) - LBound(a, 1) + 1 Else NumRowsToPaste = WorksheetFunction.min(NumRowsToPaste, UBound(a, 1)) | |
If NumColsToPaste = 0 Then NumColsToPaste = UBound(a, 2) - LBound(a, 2) + 1 Else NumColsToPaste = WorksheetFunction.min(NumColsToPaste, UBound(a, 2)) | |
FirstCellToPasteIn.Range("A1:" & Cells(NumRowsToPaste, NumColsToPaste).Address).Formula = a | |
n_PasteFormula = True | |
End Function | |
Function n_G(firstcell, Optional Direction As n_Direction_Enum = DirDown, Optional MaximumCols = 0, Optional MaximumRows = 0) | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
n_G = n_GetRangeValues(FirstCellToPasteIn, Direction, MaximumCols, MaximumRows) | |
End Function | |
Function n_GetRangeValues(firstcell, Optional Direction As n_Direction_Enum = DirDown, Optional maxcolumns = 0, Optional maxrows = 0) | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
n_GetRangeValues = n_RangeEnd(FirstCellToPasteIn, Direction, CInt(maxcolumns), CInt(maxrows)).Value2 | |
End Function | |
Function n_GetAllValues(wspointer, Optional StartFromRow As Long = 1) As Variant | |
n_GetAllValues = wspointer.Range("A" & StartFromRow & ":" & n_LastCell(wspointer).Address).Value2 | |
End Function | |
Function n_GetRangeFormula(firstcell, Optional Direction As n_Direction_Enum = DirDown, Optional maxcolumns = 0, Optional maxrows = 0) | |
Dim FirstCellToPasteIn As Range | |
If IsObject(firstcell) Then Set FirstCellToPasteIn = firstcell Else Set FirstCellToPasteIn = Range(firstcell) | |
n_GetRangeFormula = n_RangeEnd(FirstCellToPasteIn, Direction, CDbl(maxcolumns), CDbl(maxrows)).Formula | |
End Function | |
Function n_GetAllFormulas(wspointer, Optional StartFromRow As Long = 1) As Variant | |
n_GetAllFormulas = wspointer.Range("A" & StartFromRow & ":" & n_LastCell(wspointer).Address).Formula | |
End Function | |
Function n_RangeEnd(firstcell, Optional Direction As n_Direction_Enum = DirNone, Optional maxcolumns As Double = 0, Optional maxrows As Double = 0) As Range | |
Dim anyRange As Range | |
If IsObject(firstcell) Then Set anyRange = firstcell Else Set anyRange = Range(firstcell) | |
Dim lastcell As Range | |
Select Case Direction | |
Case DirRight | |
Set lastcell = anyRange.End(xlToRight) | |
Case DirDown | |
Set lastcell = anyRange.End(xlDown) | |
Case DirRightDown | |
Set lastcell = anyRange.End(xlToRight).End(xlDown) | |
Case DirDownRight | |
Set lastcell = anyRange.End(xlDown).End(xlToRight) | |
Case Else | |
Set lastcell = anyRange | |
End Select | |
If maxcolumns > 0 And lastcell.Column - anyRange.Column + 1 > maxcolumns Then | |
Set lastcell = lastcell.Offset(0, maxcolumns - lastcell.Column + anyRange.Column - 1) | |
End If | |
If maxrows > 0 And lastcell.row - anyRange.row + 1 > maxrows Then | |
Set lastcell = lastcell.Offset(maxrows - lastcell.row + anyRange.row - 1, 0) | |
End If | |
Set n_RangeEnd = anyRange.Parent.Range(anyRange.Address & ":" & lastcell.Address) | |
End Function | |
Function n_Wait(NumberOfSeconds) As Boolean | |
Dim newHour, newMinute, newSecond, numHour, numMinute, numSecond | |
numHour = WorksheetFunction.RoundDown(NumberOfSeconds / (60 * 60), 0) | |
numMinute = WorksheetFunction.RoundDown((NumberOfSeconds - numHour * 60) / 60, 0) | |
numSecond = NumberOfSeconds - numHour * 60 * 60 - numMinute * 60 | |
newHour = Hour(Now()) + numHour | |
newMinute = Minute(Now()) + numMinute | |
newSecond = second(Now()) + numSecond | |
n_Wait = Application.Wait(TimeSerial(newHour, newMinute, newSecond)) | |
End Function | |
Function n_UpdateStatus(location As Range, thestatus As String, Optional usestatusbar As Boolean = False) As Boolean | |
If usestatusbar Then | |
Application.StatusBar = thestatus | |
Else | |
Dim z, x | |
Set z = ActiveWorkbook | |
Set x = ActiveSheet | |
Application.ScreenUpdating = True | |
'location.Parent.Parent.Activate | |
'location.Parent.Activate | |
location.Worksheet.Activate | |
location.Value2 = thestatus | |
Application.ScreenUpdating = False | |
z.Activate | |
x.Activate | |
End If | |
End Function | |
Function n_T(a, Optional If1DimItShouldBeARow As Boolean = False) | |
n_T = n_Transpose(a, If1DimItShouldBeARow) | |
End Function | |
Function n_Transpose(a, Optional If1DimItShouldBeARow As Boolean = False) | |
If n_Is1Dim(a) Then | |
n_Transpose = n_Ensure2DArray(a, If1DimItShouldBeARow) | |
Else | |
If UBound(a, 1) = 1 Or UBound(a, 2) = 1 Then | |
GoTo errhandle | |
Else | |
On Error GoTo errhandle 'in case the stuff in the array is too long for transpose to handle. | |
n_Transpose = WorksheetFunction.Transpose(a) | |
End If | |
End If | |
errhandle: | |
Dim ta(), x, y | |
ReDim ta(LBound(a, 2) To UBound(a, 2), LBound(a, 1) To UBound(a, 1)) | |
For x = LBound(a, 2) To UBound(a, 2) | |
For y = LBound(a, 1) To UBound(a, 1) | |
ta(x, y) = a(y, x) | |
Next y | |
Next x | |
n_Transpose = ta | |
End Function | |
Function n_Is1Dim(a) As Boolean | |
On Error GoTo yesitis | |
Debug.Print UBound(a, 2) | |
n_Is1Dim = False | |
Exit Function | |
yesitis: | |
n_Is1Dim = True | |
End Function | |
Function n_Ensure1DArray(thevar) | |
If IsObject(thevar) Then thevar = thevar.Value | |
If Not IsArray(thevar) Then | |
n_Ensure1DArray = Array(thevar) | |
Else | |
If n_Is1Dim(thevar) Then | |
n_Ensure1DArray = thevar | |
Else | |
Dim tempvar, tempc | |
ReDim tempvar(LBound(thevar) To UBound(thevar)) | |
If UBound(thevar, 1) = 1 Then ' row vector | |
For tempc = LBound(tempvar) To UBound(tempvar) | |
tempvar(tempc) = thevar(1, tempc) | |
Next tempc | |
Else | |
For tempc = LBound(tempvar) To UBound(tempvar) | |
tempvar(tempc) = thevar(tempc, 1) | |
Next tempc | |
End If | |
n_Ensure1DArray = tempvar | |
End If | |
End If | |
End Function | |
Function n_Ensure2DArray(ByVal a, Optional If1DimItShouldBeARow As Boolean = False) | |
If IsObject(a) Then a = a.Value | |
If n_Is1Dim(a) Then | |
Dim temparr(), e2dac | |
If IsArray(a) Then | |
ReDim temparr(LBound(a) To UBound(a), 1 To 1) | |
For e2dac = LBound(a) To UBound(a) | |
temparr(e2dac, 1) = a(e2dac) | |
Next e2dac | |
If If1DimItShouldBeARow Then n_Ensure2DArray = n_Transpose(temparr) Else n_Ensure2DArray = temparr | |
Else | |
ReDim temparr(1 To 1, 1 To 1) | |
temparr(1, 1) = a | |
n_Ensure2DArray = temparr | |
End If | |
Else | |
n_Ensure2DArray = a | |
End If | |
End Function | |
Function n_CheckAllSame(ByVal a, Optional NotSameMessageBox As String = "") As Boolean | |
n_CheckAllSame = True | |
If IsEmpty(a) Or UBound(a) < 2 Then Exit Function | |
a = n_Ensure2DArray(a) | |
Dim i, j, comparable | |
i = LBound(a, 1) | |
j = LBound(a, 2) | |
comparable = a(i, j) | |
For i = i + 1 To UBound(a, 1) | |
If a(i, j) <> comparable Then | |
n_CheckAllSame = False | |
If NotSameMessageBox <> "" Then MsgBox NotSameMessageBox | |
Exit Function | |
End If | |
Next i | |
If j > 1 Then | |
i = LBound(a, 1) | |
j = LBound(a, 2) | |
For i = i + 1 To UBound(a, 1) | |
For j = j + 1 To UBound(a, 1) | |
If a(i, j) <> comparable Then | |
n_CheckAllSame = False | |
If NotSameMessageBox <> "" Then MsgBox NotSameMessageBox | |
Exit Function | |
End If | |
Next j | |
Next i | |
End If | |
End Function | |
Function n_WhereInArray(thing, V) As Variant | |
n_WhereInArray = False | |
V = n_Ensure1DArray(V) | |
Dim wiacounter | |
For wiacounter = LBound(V) To UBound(V) | |
If thing = V(wiacounter) Then | |
n_WhereInArray = wiacounter + 1 - LBound(V) | |
Exit For | |
End If | |
Next wiacounter | |
End Function | |
Function n_EC(M, Colnumtoextract) | |
n_EC = n_Extract(nCol, M, Colnumtoextract) | |
End Function | |
Function n_ER(M, Rownumtoextract) | |
n_ER = n_Extract(nRow, M, Rownumtoextract) | |
End Function | |
Function n_Extract(ColOrRow As n_RowCol_Enum, ByVal M, RowOrColnumtoextract) | |
Dim j, k, output, i | |
M = n_Ensure2DArray(M) | |
If ColOrRow = nCol Then | |
If IsArray(RowOrColnumtoextract) Then | |
ReDim output(LBound(M, 1) To UBound(M, 1), UBound(RowOrColnumtoextract)) | |
i = 1 | |
For Each k In RowOrColnumtoextract | |
For j = LBound(M, 1) To UBound(M, 1) | |
output(j, i) = M(j, k) | |
Next j | |
i = i + 1 | |
Next k | |
Else | |
ReDim output(LBound(M, 1) To UBound(M, 1), 1) | |
For i = LBound(M, 1) To UBound(M, 1) | |
output(i, 1) = M(i, RowOrColnumtoextract) | |
Next i | |
End If | |
Else | |
If IsArray(RowOrColnumtoextract) Then | |
ReDim output(UBound(RowOrColnumtoextract), LBound(M, 2) To UBound(M, 2)) | |
i = 1 | |
For Each k In RowOrColnumtoextract | |
For j = LBound(M, 2) To UBound(M, 2) | |
output(i, j) = M(k, j) | |
Next j | |
i = i + 1 | |
Next k | |
Else | |
ReDim output(1, LBound(M, 2) To UBound(M, 2)) | |
For i = LBound(M, 2) To UBound(M, 2) | |
output(1, i) = M(RowOrColnumtoextract, i) | |
Next i | |
End If | |
End If | |
n_Extract = output | |
End Function | |
Function n_ColNum2Letter(colnum As Integer) | |
If colnum > 27 Then | |
n_ColNum2Letter = Left(Range("A1").Offset(0, colnum - 1).Address, 1) | |
Else | |
n_ColNum2Letter = Left(Range("A1").Offset(0, colnum - 1).Address, 2) | |
End If | |
End Function | |
'------------------------------------------------------------------------------------------------------------------------ | |
'---------------------------------------------------data processing------------------------------------------------------ | |
'------------------------------------------------------------------------------------------------------------------------ | |
Function n_Filter(ByVal M, FilterColumn As Integer, FilterCriterion, Optional If1FilterOut2MoreThan3LessThan As Integer = 0, Optional wWS) | |
'Returns a shorter array filtered with only the rows containing things specified in FilterCriterion in their FilterColumn. Some variations allowed. | |
'give it a working worksheet for bigger filter jobs. however worksheet format may force some texts to dates. | |
FilterCriterion = n_Ensure1DArray(FilterCriterion) | |
'add sort flag | |
M = n_Append(nCol, M) | |
Dim i | |
Select Case If1FilterOut2MoreThan3LessThan | |
Case 1 | |
For i = 1 To UBound(M, 1) | |
If n_WhereInArray(M(i, FilterColumn), FilterCriterion) <> False Then _ | |
M(i, UBound(M, 2)) = "N" Else M(i, UBound(M, 2)) = "Y" | |
Next i | |
Case 2 | |
For i = 1 To UBound(M, 1) | |
If M(i, FilterColumn) > FilterCriterion(1) Then _ | |
M(i, UBound(M, 2)) = "Y" Else M(i, UBound(M, 2)) = "N" | |
Next i | |
Case 3 | |
For i = 1 To UBound(M, 1) | |
If M(i, FilterColumn) < FilterCriterion(1) Then _ | |
M(i, UBound(M, 2)) = "Y" Else M(i, UBound(M, 2)) = "N" | |
Next i | |
Case Else | |
For i = 1 To UBound(M, 1) | |
If n_WhereInArray(M(i, FilterColumn), FilterCriterion) <> False Then _ | |
M(i, UBound(M, 2)) = "Y" Else M(i, UBound(M, 2)) = "N" | |
Next i | |
End Select | |
'shortcut for empty filters | |
If n_WhereInArray("Y", n_Extract(nCol, M, UBound(M, 2))) = False Then 'filtered out everything | |
n_Filter = False 'return false | |
Exit Function | |
End If | |
'sort | |
If IsObject(wWS) Then | |
Dim mustdel As Boolean, curws | |
mustdel = n_ClearWorksheet(wWS) | |
Call n_PasteValue(wWS.Range("A2"), M) | |
For i = 1 To UBound(M, 2) | |
wWS.Range("A1").Offset(0, i - 1).Value2 |