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），并且还会处理实际上是数字的输入，因此它将忽略文本等）： / p>

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

编写VBA代码以查找几何均值

3 个答案: