Im trying to write a weighted Standard Deviation function in VBA. 2 ranged inputs are supposed to output a value. However, it returns a #value error.
Edit: added worksheet.function
Public Function StDevWeighted(data As Range, weight As Range) As Double
'https://stats.stackexchange.com/questions/6534/how-do-i-calculate-a-weighted-standard-deviation-in-excel
Dim mean, top, bottom
mean = WorksheetFunction.SumProduct(data, weight) / WorksheetFunction.Length(data)
top = WorksheetFunction.SumProduct(weight, (data - mean) ^ 2)
bottom = ((WorksheetFunction.Length(data) - 1) / WorksheetFunction.Length(data)) * WorksheetFunction.Sum(weight)
StDevWeighted = WorksheetFunction.SQRT(top / bottom)
End Function
So, unfortunately you have to do the work to calculate the square differences by yourself, item-by-item, and store the answers in a temporary array (see comments for why). I haven't checked the maths ... above my pay-grade!
Public Function StDevWeighted(rngData As Range, rngWeight As Range) As Double
Dim dMean As Double
Dim dTop As Double
Dim dBottom As Double
Dim vData As Variant
vData = rngData
dMean = WorksheetFunction.SumProduct(rngData, rngWeight) / rngData.Count
Dim vSqDiff() As Variant
ReDim vSqDiff(1 To UBound(vData, 1), 1 To UBound(vData, 2))
For r = 1 To UBound(vData, 1)
For c = 1 To UBound(vData, 2)
vSqDiff(r, c) = (vData(r, c) - dMean) ^ 2
Next c
Next r
dTop = WorksheetFunction.SumProduct(rngWeight, vSqDiff)
dBottom = ((rngData.Count - 1) / rngData.Count) * WorksheetFunction.Sum(rngWeight)
StDevWeighted = Sqr(dTop / dBottom)
End Function
PS. I tested this from my spreadsheet directly using the Debugger.
Related
I need to write a function that takes a range of values (X) and their associated uncertainties (E) and outputs a weighted average. However, I can't get the function to loop over the array without producing a value error (#VALUE!). I'd also like it to just return the value of X if only one cell is entered as an input for X. Here is where I'm at thus far:
' Calculates the weighted average of arrays of values, X, and their errors, E
Option Explicit
Function WAV(X As Variant, E As Variant) As Double
' Update values upon changing spreadsheet
Application.Volatile
' Test if we have an array or not
If IsArray(X) And IsArray(E) Then
Dim W As Double
Dim WX As Double
W = 0
WX = 0
WAV = 20
For myrow = LBound(X,1) To UBound(X,1)
For mycol = LBound(X, 2) To UBound(X, 2)
'Test if X and E are both numbers and E > 0
If (Application.WorksheetFunction.IsNumber(X(myrow, mycol)) = True) And (Application.WorksheetFunction.IsNumber(E(myrow, mycol)) = True) Then
If E(myrow, mycol) > 0 Then
W = W + 1 / (E(myrow, mycol) ^ 2)
WX = WX + X(myrow, mycol) / (E(myrow, mycol) ^ 2)
End If
End If
Next mycol
Next
If W > 0 Then
WAV = WX / W
End If
Else
WAV = X
End If
End Function
I have wrestled with this for several hours, but to no avail. I'm also a beginner with VBA so I suspect I have made a stupid mistake somewhere. Any help would be appreciated.
Thanks to both BigBen and ScottCraner for their help in answering this question. Here is a working solution incorporating both of their suggestions:
Option Explicit
Function WAV(X As Variant, E As Variant) As Double
' Update values upon changing spreadsheet
Application.Volatile
' Test if we have an array or not
If IsArray(X) And IsArray(E) Then
' Change all the ranges into arrays
Dim XArr() As Variant
Dim EArr() As Variant
Dim WArr() As Variant
' Assign the array values
XArr = X.Value
EArr = E.Value
' Resize the weighting array
ReDim WArr(LBound(EArr, 1) To UBound(EArr, 1), LBound(EArr, 2) To UBound(EArr, 2))
' Calculate square inverses of errors
For myrow = LBound(EArr, 1) To UBound(EArr, 1)
For mycol = LBound(EArr, 2) To UBound(EArr, 2)
WArr(myrow, mycol) = 1 / (EArr(myrow, mycol) ^ 2)
Next mycol
Next myrow
' Now calculate the weighted average using sumproduct function
Dim W As Double
Dim WX As Double
WX = WorksheetFunction.SumProduct(XArr, WArr)
W = WorksheetFunction.SumProduct(WArr)
' Return weighted average
WAV = WX / W
Else
' Return the weighted average
WAV = X
End If
End Function
I've got this code to calculate the cumulative geometric average of around 500 values (500 rows, 1 column) but I have tried to double check this and I am not getting the correct geometric average values.
Sub GeoR()
Dim No_Values As Integer
No_Values = 500
Dim Product() As Double
Dim Geo() As Double
Dim r() As Double
ReDim r(No_Values)
ReDim Geo(No_Values)
ReDim Product(No_Values)
For i = 1 To No_Values
r(i) = Range("returns").Cells(i, 1)
Product(i) = Application.Product(1 + r(i))
Geo(i) = (Product(i) ^ (1 / i)) - 1
Range("output").Cells(i, 1) = Geo(i)
Next i
End Sub
Could someone please help correct this code?
why don't you use the worksheetfunction?
Function geo(rng As Range) As Double
geo = Application.WorksheetFunction.GeoMean(rng)
End Function
example to call this
Sub geotest()
Debug.Print geo(ActiveSheet.Range("A1:A500"))
End Sub
I'm trying to generate a linear and quadratic regression of some data I have using vba. Simple enough right? The problem is when I use the linest function, I'm not getting the results I was hoping for (a 2d array containing the x values in the first column and the y values in the second column), and instead I'm receiving "Error 2015".
I know that linest is supposed to return the coefficients of a linear/quadratic regression, so I tried just creating a y=mx+b in my code to generate the arrays I want. I have yet to find success doing this.
Avg & P2 are the variables for the input data.
Dim lin() As Variant 'linear regression'
Dim quad() As Variant 'polynomial regression'
Dim RMSE1 As Single 'RMSE of linear regression'
Dim RMSE2 As Single 'RMSE of quadratc regression'
Dim nAvg() As Variant 'Avg values being looked at in current loop'
Dim nP2() As Variant 'P2 values being looked at in current loop'
Dim k As Single 'Ratio of RMSE1/RMSE2'
Dim linEstOut() As Variant
Dim linSlope As Single
Dim linB As Single
Dim quadEstOut() As Variant
Dim quadSlope As Single
Dim quadB As Single
Dim quadC As Single
For i = 2 To UBound(P2)
ReDim Preserve lin(i)
ReDim Preserve quad(i)
ReDim Preserve nAvg(i)
ReDim Preserve nP2(i)
ReDim Preserve linEstOut(i)
ReDim Preserve quadEstOut(i)
nAvg(1) = Avg(1)
nP2(1) = P2(1)
nAvg(i) = Avg(i)
nP2(i) = P2(i)
'linear regression'
linEstOut(i) = Application.LinEst(nAvg, nP2, 1, 0) 'linest returns a slope'
linSlope = linEstOut(1)
linB = linEstOut(2)
For j = 1 To UBound(lin)
lin(j) = (linSlope * nP2(j)) + linB
Next j
'quadratic regression'
quadEstOut = Application.LinEst(nAvg, Application.Power(nP2, Array(1, 2)), True, False)
quadSlope = quadEstOut(1)
quadB = quadEstOut(2)
quadC = quadEstOut(3)
For j = 1 To UBound(quad)
quad = (quadSlope * nP2(i) ^ 2) + (quadB * nP2(i)) + quadC
Next j
'RMSE'
RMSE1 = (Application.WorksheetFunction.SumSq(lin) / i) ^ (1 / 2)
RMSE2 = (Application.WorksheetFunction.SumSq(quad) / i) ^ (1 / 2)
'Calculate K value'
k = RMSE1 / RMSE2 'Greater than 1, non linear; close to 1, linear'
'Determine if the region is linear or quadtratic'
If k > 1 Then
tpx = nP2(i) 'turning point x'
tpy = nAvg(i) 'turning point y'
Exit For
Else
End If
Next i
I have not gotten any output besides error messages yet. The desired output is two arrays containing the y-values of the linear/quadratic regression.
Regarding the code you have in your question: When dealing with regressions, you have to be aware that by default VBA arrays are starting at 0 and you need to specify when you (re)dim them that you want them to start at 1 which is the convention when doing regressions.
In you code, when you were running the line below, you had an empty value for nAvg(0) and nP2(0) which gave you the Error 2015 (#Value cell error).
linEstOut(i) = Application.LinEst(nAvg, nP2, 1, 0)
Hence, for anything that will contain regression data, I would suggest doing to redim them like this
ReDim Preserve nAvg(1 to i)
ReDim Preserve nP2(1 to i)
Side note: you could also Option Base 1 at the top of your module to override the default at the module level, but your macros will start breaking if you copy them to other modules, so that is not recommended.
Regarding your comment and the second part of your question:
For how to generate a polynomial regression with VBA, you can have a look at this answer.
I am having some trouble figuring out how to return an array within a UDF from another UDF. The one here is a simple exponential moving average UDF and I am trying to return the array into another UDF but I am getting #value error. I feel there is a simple solution that I am not seeing. All help is greatly appreciated, thanks.
Function ema(arg1 As Variant, ByVal lngth As Long) As Variant
x = arg1
dim avg As Double
avg = 1
Dim arrema As Variant
arrema = Array()
ReDim arrema(1 To UBound(x, 1), 1 To 1)
For j = 1 To (UBound(x, 1) - lngth)
For i = (1 + j - 1) To (lngth + j - 1)
avg = (WorksheetFunction.Index(x, i, 1) + 1) * avg
Next i
arrema(j, 1) = avg ^ (1 / lngth)
avg = 1
Next j
'ema = avg ^ (1 / lngth)
ema = arrema
End Function
Function test(arg2 As Variant, xlength As Long)
Dim arra As Variant
'Call ema(arg2, xlength)
Dim arr As Variant
arr = Array()
ReDim arr(1 To UBound(arg2, 1), 1 To 1)
arra = ema(arg2, xlength)
For i = 1 To UBound(arg2, 1) - xlength
arr(i, 1) = arra(i, 1)
Next i
test = arr
End Function
If you are calling test from a formula with a range as the arg1 parameter, then your problem is you are treating a Range as if it were an Array by calling UBound(arg2,1)
Change that to UBound(arg2.Value,1) and it will work.
Further explanation:
By declaring the arg# parameters as Variant allows the UDFs to be called with either Range's or Array's. It may be better to be specific by using either As Range or As Variant().
In Function ema this issue is avoided by the line x = arg1: If arg1 is a Range then this copies the default property of the Range which is the Value property to x, making x an array. If arg1 is an Array then it just copies that array into x.
Net result is Function ema can handle either Ranges or Arrays. There is another issue there though: WorksheetFunction.Index(x, i, 1) will fail with one dimensional Arrays. Change it to WorksheetFunction.Index(x, i) or better still Application.Index(x, i) to avoid this issue too.
I have data stored in some column (Say, Column A). The length of Column A is not fixed (depends on previous steps in the code).
I need a histogram for the values in Column A, and have it in the same sheet. I need to take the values in column A, and automatically compute M Bins, then give the plot.
I looked online for a "simple" code, but all codes are really fancy, with tons of details that I don't need, to the extent that I am not even able to use it. (I am a VBA beginner.)
I found the following code that seems to do the job, but I am having trouble even calling the function. Besides, it only does computations but does not make the plot.
Sub Hist(M As Long, arr() As Single)
Dim i As Long, j As Long
Dim Length As Single
ReDim breaks(M) As Single
ReDim freq(M) As Single
For i = 1 To M
freq(i) = 0
Next i
Length = (arr(UBound(arr)) - arr(1)) / M
For i = 1 To M
breaks(i) = arr(1) + Length * i
Next i
For i = 1 To UBound(arr)
If (arr(i) <= breaks(1)) Then freq(1) = freq(1) + 1
If (arr(i) >= breaks(M - 1)) Then freq(M) = freq(M) + 1
For j = 2 To M - 1
If (arr(i) > breaks(j - 1) And arr(i) <= breaks(j)) Then freq(j) = freq(j) + 1
Next j
Next i
For i = 1 To M
Cells(i, 1) = breaks(i)
Cells(i, 2) = freq(i)
Next i
End Sub
And then I try to call it simply by:
Sub TestTrial()
Dim arr() As Variant
Dim M As Double
Dim N As Range
arr = Range("A1:A10").Value
M = 10
Hist(M, arr) ' This does not work. Gives me Error (= Expected)
End Sub
A little late but still I want to share my solution. I created a Histogram function which might be used as array formula in the excel spread sheet. Note: you must press
CTRL+SHIFT+ENTER to enter the formula into your workbook. Input is the range of values and the number M of bins for the histogram. The output range must have M rows and two columns. One column for the bin value and one column for the bin frequency.
Option Explicit
Option Base 1
Public Function Histogram(arr As Range, M As Long) As Variant
On Error GoTo ErrHandler
Dim val() As Variant
val = arr.Value
Dim i As Long, j As Integer
Dim Length As Single
ReDim breaks(M) As Single
ReDim freq(M) As Integer
Dim min As Single
min = WorksheetFunction.min(val)
Dim max As Single
max = WorksheetFunction.max(val)
Length = (max - min) / M
For i = 1 To M
breaks(i) = min + Length * i
freq(i) = 0
Next i
For i = 1 To UBound(val)
If IsNumeric(val(i, 1)) And Not IsEmpty(val(i, 1)) Then
If val(i, 1) > breaks(M) Then
freq(M) = freq(M) + 1
Else
j = Int((val(i, 1) - min) / Length) + 1
freq(j) = freq(j) + 1
End If
End If
Next i
Dim res() As Variant
ReDim res(M, 2)
For i = 1 To M
res(i, 1) = breaks(i)
res(i, 2) = freq(i)
Next i
Histogram = res
ErrHandler:
'Debug.Print Err.Description
End Function
Not 100% sure as to the efficacy of that approach but;
Remove the parens as your calling a sub; Hist M, arr
M is declared as double but received by the function as a long; this won't work so declare it in the calling routine as long
You will need to recieve arr() As Variant
Range -> Array produces a 2 dimensional array so the elements are arr(1, 1) .. arr(n, 1)