编写用于查找几何平均值的VBA代码

Question

我正在尝试创建一个计算几何平均值的自定义 VBA 函数。我知道已经有一个工作表函数，但我正在尝试自己编写。几何平均值 = n 个数字的倍数的第 n 个根。

例如：假设您在 excel 列中有以下 2 个数字：2、8

几何平均值 = (2*8(^(1/n(; n = 2，因为有 2 个数字，2 和 8。 所以，几何平均值 = (2*8(^(1/2(=16^(1/2( = 4

所以我必须编写一个简单的 VBA-excel 代码/函数来查找 excel 列中任何一组数字的几何平均值。我写了一个代码，但它没有给我正确的答案，你能帮我纠正它吗？

Option Explicit
Function Geometric(rs)
Dim Sum as single
Dim i As Integer
Dim n As Integer
n = rs.Count
For i = 1 To n
sum = sum + (rs(i)) ^ (1 / n)
Next i
Geometric = sum
End Function

Answer 1

这将考虑不同类型的输入(我称输入arg_vNumbers而不是rs(，并且也只处理实际上是数字的输入，因此它将忽略文本等(：

Public Function GEOMETRICMEAN(ByVal arg_vNumbers As Variant) As Variant
Dim rConstants As Range
Dim rFormulas As Range
Dim rAdjusted As Range
Dim vElement As Variant
Dim lTotalElements As Long
Dim dProductTotal As Double
Select Case TypeName(arg_vNumbers)
Case "Range"
If arg_vNumbers.Rows.Count = arg_vNumbers.Parent.Rows.Count Then
Set rAdjusted = Intersect(arg_vNumbers.Parent.UsedRange, arg_vNumbers)
Else
Set rAdjusted = arg_vNumbers
End If
On Error Resume Next
Set rConstants = rAdjusted.SpecialCells(xlCellTypeConstants, xlNumbers)
Set rFormulas = rAdjusted.SpecialCells(xlCellTypeFormulas, xlNumbers)
On Error GoTo 0
Select Case Abs((rConstants Is Nothing) + 2 * (rFormulas Is Nothing))
Case 0: Set rAdjusted = Union(rConstants, rFormulas)
Case 1: Set rAdjusted = rFormulas
Case 2: Set rAdjusted = rConstants
Case 3: GEOMETRICMEAN = CVErr(xlErrDiv0)
Exit Function
End Select
For Each vElement In rAdjusted
If IsNumeric(vElement) And Len(vElement) > 0 Then
lTotalElements = lTotalElements + 1
If lTotalElements = 1 Then
dProductTotal = vElement
Else
dProductTotal = dProductTotal * vElement
End If
End If
Next vElement
If lTotalElements > 0 Then
GEOMETRICMEAN = dProductTotal ^ (1 / lTotalElements)
Else
GEOMETRICMEAN = CVErr(xlErrDiv0)
End If
Case "Variant()", "Collection", "Dictionary"
For Each vElement In arg_vNumbers
If IsNumeric(vElement) Then
lTotalElements = lTotalElements + 1
If lTotalElements = 1 Then
dProductTotal = vElement
Else
dProductTotal = dProductTotal * vElement
End If
End If
Next vElement
If lTotalElements > 0 Then
GEOMETRICMEAN = dProductTotal ^ (1 / lTotalElements)
Else
GEOMETRICMEAN = CVErr(xlErrDiv0)
End If
Case Else
If IsNumeric(arg_vNumbers) Then
GEOMETRICMEAN = arg_vNumbers
Else
GEOMETRICMEAN = CVErr(xlErrDiv0)
End If
End Select
End Function

这样做的优点是，除了接受一系列数字之外，它还可以接受用户定义的数组作为工作表公式的一部分，例如：=GEOMETRICMEAN({2,8})。 它还可以接受VBA数组，集合和字典，并且仅处理这些对象的数字部分。 如果输入中的任何位置不包含任何数字，则返回#DIV/0!错误。

这些允许和错误处理导致此 UDF 的行为与内置GEOMEAN函数的行为非常接近。

Answer 2

无需循环，只需使用Application.Product

Function Geometric(rs As Range)
Dim Sum As Double
Dim n As Long
n = rs.Count
Sum = Application.Product(rs) ^ (1 / n)
Geometric = Sum
End Function

Answer 3

你的公式是错误的，使用这个：

Option Explicit
Function Geometric(rs as range)
Dim dGM As Double
Dim i As Integer
Dim n As Integer
n = rs.Count
dGM = 1
For i = 1 To n
dGM = dGM * rs(i)
Next i
Geometric = dGM ^ (1 / n)
End Function