excel - 编写 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 的行为非常接近。功能。