Skip to content

Instantly share code, notes, and snippets.

@sw-yx

sw-yx/Newton-1.29.vb

Last active Nov 13, 2020
Star
Embed
What would you like to do?
Learn more about clone URLs
Download ZIP
Newton - my VBA utility library for doing matrix multiplication and other useful automations during my finance days https://twitter.com/swyx/status/1327041894853922816
Raw
Newton-1.29.vb
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 = i
Next i
Set curws = ActiveSheet
wWS.Activate
wWS.Range("A1:" & n_LastCell(wWS).Address).Select
Selection.AutoFilter
ActiveSheet.Range("A1:" & n_LastCell(wWS).Address).AutoFilter Field:=UBound(M, 2), Criteria1:="Y"
Rows("2:" & UBound(M, 1) + 1).Select
Selection.Copy