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
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 am very new to VBA. I am trying to calculate the rolling means of a range, I certain my mistake is something very silly
Function Rolling_Mean(Prices as Range)
Dim window as Long, i As Integer, temp_sum as Long
Dim means() as Long
window = 10
temp_sum = 0
ReDim means(1 to 253)
For i = 1 to 253
temp_sum = temp_sum + Prices(i)
If i Mod window = 0 Then
means(i) = temp_sum / 10
temp_sum = 0
End If
Next
Rolling_Mean = means
End Function
I keep getting an error or an array of 0s. I think my issue is how im trying to access the Prices. I am also wondering how to implement the syntax AVERAGE(Prices(1) to Prices(10)) as that would help a lot as well.
This will be run in the sheet with =Rolling_Mean(B2:B253)
This seems to work for me. Added the window as a second parameter.
Function Rolling_Mean(Prices As Range, window As Long)
Dim i As Long, sum As Double
Dim means(), data
data = Prices.Value 'assuming a single column of cells....
ReDim means(1 To UBound(data, 1), 1 To 1)
For i = 1 To UBound(data, 1)
sum = sum + data(i, 1)
If i >= window Then
means(i, 1) = sum / window
sum = sum - data(i - window + 1, 1) 'subtract value from trailing end of window
Else
means(i, 1) = ""
End If
Next i
Rolling_Mean = means
End Function
If your Excel version doesn't have "auto spill" then you'll need to enter it as an array formula (Ctrl+Shift+Enter)
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.
I try to write a function that takes a number x_0 and vector of ordered numbers y_0, y_1, y_2, ..., and determines indices k, k + 1 such that y_k <= x_0 < y_k + 1.
Simply, between which two values of y_k the value x_0 falls.
In the code below I used x_0=10and y_0=2, y_1=5, y_2=7, y_3=11, y_4=13, y_5=16. The function should output (2,3) as the value of x_0=10 is between y_2=7and y_3=11.
Firstly I tried this but I got
"Run time error 1004:Unable to get the Match property of the WorksheetFunction class"
in the line four.
Function Indic(x_0, y)
Set x_0 = Range("E10")
XValue = x_0.Value
y_k = Application.WorksheetFunction.Index(y, Application.WorksheetFunction.Match(x_0, XValue, 1))
y_k_1 = Application.WorksheetFunction.Index(y, Application.WorksheetFunction.Match(x_0, XValue, 1) + 1)
End Function
So I wanted to rewrite the function without using "Match" function but I ended up stuck and I dont know how to continue.
Function Indic(x_0, y)
Set x_0 = Range("E10")
XValue = x_0.Value
Set y = Range("E12:E17")
YValue = y.Value
End Function
Sub try()
With Worksheets("Sheet1")
Debug.Print (Indic(.Range("E10"), .Range("E12:E17")))
End With
End Sub
Any help is greatly appreciated.
You don't need a function for this you can just use Application.Match directly, it finds the lower index of both. The upper one then is the LowerIndex + 1
Public Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Tabelle3")
Dim MatchResult As Variant
MatchResult = Application.Match(ws.Range("E10").Value, ws.Range("E12:E17"), 1)
If IsError(MatchResult) Then
MsgBox "Matching failed", vbCritical
Exit Sub
End If
Dim LowerIndex As Double
LowerIndex = MatchResult - 1 'we need to subtract 1 because your index starts with `0` but row counting with `1`
Dim UpperIndex As Double
UpperIndex = LowerIndex + 1
Debug.Print LowerIndex, UpperIndex
End Sub
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)