寻找用于 VBA 的功能最小化器

Posted 2023-04-13

【中文标题】寻找用于 VBA 的功能最小化器

【英文标题】：looking for a functional minimizer for use in VBA

【发布时间】：2012-07-17 18:45:58

【问题描述】：

您好，我是 VBA 代码的新手，正在努力在 Excel 中的 UDF 内进行一些非线性曲线拟合。我熟悉 Matlab，我的大部分经验都来自于此。我正在寻找一个子/函数，它将为我提供类似于 Matlab 中的 fminsearch() 的功能。任何帮助，将不胜感激。谢谢

编辑(2) 回应布拉德

假设我想编写自己的 UDF，它使用最小化来迭代地找到数字的立方根。我可以编写以下函数吗？

Function myCubRootSResd(root As Double, rootCubed As Double) As Double 
Dim a As Double 
a = (root * root * root - rootCubed)
myCubRootSResd = a * a
End Function 

然后，这可以与 Solver 结合使用，通过更改输入“root”将此函数的输出设置为零来查找任何数字的立方根。然而，这只是我需要在我尝试编写的 UDF 中执行的一个步骤，并且我需要在我的 UDF 内部使用这个输出（在本例中为立方根），它最终计算最终输出。然后我想使用相对引用来使用我的整体 UDF 来计算一系列输入。我相信这需要在 VBA 内部进行最小化，而不是参考单元格。在这种情况下，封装函数将处理“root”的值并返回它。它只有一个输入，即“rootCubed”，并将其传递给 myCubeRootSResd。所以它看起来像这样：

Function myCubeRootFinder(rootCubed as Double) as Double

……. 

End Function

任何帮助都将不胜感激我一直在尝试找到一个简单的解决方案一段时间，但我还没有找到任何人在 VBA 中进行这种类型的数值最小化的示例。

我意识到这可能不是在 VBA 中解决此问题的方法，但需要保留功能。谢谢你和我一起的病人。

【问题讨论】：

我会回来看看我是否可以在今天晚些时候（当我有时间的时候）在求解器的上下文中回答这个问题，但是 Matlab 的 fminsearch 函数使用 Nelder-Mead 方法，即实际上很简单，并且可能由大学（/大学）一年级学生编码。 en.wikipedia.org/wiki/Nelder%E2%80%93Mead_method

更好：mathworks.com/help/techdoc/math/bsotu2d.html#bsgpq6p-11

【参考方案1】：

好吧，我玩得很开心。

创建一个名为 FuncEval 的类：

Option Explicit

Dim output_ As Double
Dim input_() As Double

Public Property Get VectArr() As Double()
    VectArr = input_
End Property

Public Function Vect(i As Integer)
    Vect = input_(i)
End Function

Public Sub SetVect(ByRef newVect() As Double)
    Dim i As Integer
    ReDim input_(LBound(newVect) To UBound(newVect)) As Double
    For i = LBound(newVect) To UBound(newVect)
        input_(i) = newVect(i)
    Next i
End Sub

Public Property Get Result() As Double
    Result = output_
End Property

Public Property Let Result(newRes As Double)
    output_ = newRes
End Property

还有一个名为 Func 的类：

Option Explicit

Private cube_ As Double

Public Property Let Cube(newCube As Double)
    cube_ = newCube
End Property

Public Function Eval(ByRef val() As Double) As FuncEval
    Dim ret As New FuncEval
    ret.Result = Abs(cube_ - val(0) * val(0) * val(0))
    ret.SetVect val
    Set Eval = ret
End Function

现在把这段代码放在一个标准模块中：

Option Explicit

Function NelderMead(f As Func, _
                    ByRef guess() As Double) As Double()

    'Algorithm follows that outlined here:
    'http://www.mathworks.com/help/techdoc/math/bsotu2d.html#bsgpq6p-11

    'Used as the perturbation for the initial guess when guess(i) == 0
    Dim zeroPert As Double
    zeroPert = 0.00025
    'The factor each element of guess(i) is multiplied by to obtain the
    'initial simplex
    Dim pertFact As Double
    pertFact = 1.05
    'Tolerance
    Dim eps As Double
    eps = 0.000000000001

    Dim shrink As Boolean
    Dim i As Integer, j As Integer, n As Integer
    Dim simplex() As Variant
    Dim origVal As Double, lowest As Double
    Dim m() As Double, r() As Double, s() As Double, c() As Double, cc() As Double, diff() As Double
    Dim FE As FuncEval, FR As FuncEval, FS As FuncEval, FC As FuncEval, FCC As FuncEval, newFE As FuncEval

    n = UBound(guess) - LBound(guess) + 1
    ReDim m(LBound(guess) To UBound(guess)) As Double
    ReDim r(LBound(guess) To UBound(guess)) As Double
    ReDim s(LBound(guess) To UBound(guess)) As Double
    ReDim c(LBound(guess) To UBound(guess)) As Double
    ReDim cc(LBound(guess) To UBound(guess)) As Double
    ReDim diff(LBound(guess) To UBound(guess)) As Double
    ReDim simplex(LBound(guess) To UBound(guess) + 1) As Variant

    Set simplex(LBound(simplex)) = f.Eval(guess)

    'Generate the simplex
    For i = LBound(guess) To UBound(guess)
        origVal = guess(i)
        If origVal = 0 Then
            guess(i) = zeroPert
        Else
            guess(i) = pertFact * origVal
        End If
        Set simplex(LBound(simplex) + i - LBound(guess) + 1) = f.Eval(guess)
        guess(i) = origVal
    Next i

    'Sort the simplex by f(x)
    For i = LBound(simplex) To UBound(simplex) - 1
        For j = i + 1 To UBound(simplex)
            If simplex(i).Result > simplex(j).Result Then
                Set FE = simplex(i)
                Set simplex(i) = simplex(j)
                Set simplex(j) = FE
            End If
        Next j
    Next i

    Do

        Set newFE = Nothing
        shrink = False
        lowest = simplex(LBound(simplex)).Result

        'Calculate m
        For i = LBound(m) To UBound(m)
            m(i) = 0
            For j = LBound(simplex) To UBound(simplex) - 1
                m(i) = m(i) + simplex(j).Vect(i)
            Next j
            m(i) = m(i) / n
        Next i

        'Calculate the reflected point
        For i = LBound(r) To UBound(r)
            r(i) = 2 * m(i) - simplex(UBound(simplex)).Vect(i)
        Next i
        Set FR = f.Eval(r)

        'Check acceptance conditions
        If (simplex(LBound(simplex)).Result <= FR.Result) And (FR.Result < simplex(UBound(simplex) - 1).Result) Then
            'Accept r, replace the worst value and iterate
            Set newFE = FR
        ElseIf FR.Result < simplex(LBound(simplex)).Result Then
            'Calculate the expansion point, s
            For i = LBound(s) To UBound(s)
                s(i) = m(i) + 2 * (m(i) - simplex(UBound(simplex)).Vect(i))
            Next i
            Set FS = f.Eval(s)
            If FS.Result < FR.Result Then
                Set newFE = FS
            Else
                Set newFE = FR
            End If
        ElseIf FR.Result >= simplex(UBound(simplex) - 1).Result Then
            'Perform a contraction between m and the better of x(n+1) and r
            If FR.Result < simplex(UBound(simplex)).Result Then
                'Contract outside
                For i = LBound(c) To UBound(c)
                    c(i) = m(i) + (r(i) - m(i)) / 2
                Next i
                Set FC = f.Eval(c)
                If FC.Result < FR.Result Then
                    Set newFE = FC
                Else
                    shrink = True
                End If
            Else
                'Contract inside
                For i = LBound(cc) To UBound(cc)
                    cc(i) = m(i) + (simplex(UBound(simplex)).Vect(i) - m(i)) / 2
                Next i
                Set FCC = f.Eval(cc)
                If FCC.Result < simplex(UBound(simplex)).Result Then
                    Set newFE = FCC
                Else
                    shrink = True
                End If
            End If
        End If

        'Shrink if required
        If shrink Then
            For i = LBound(simplex) + 1 To UBound(simplex)
                For j = LBound(simplex(i).VectArr) To UBound(simplex(i).VectArr)
                    diff(j) = simplex(LBound(simplex)).Vect(j) + (simplex(i).Vect(j) - simplex(LBound(simplex)).Vect(j)) / 2
                Next j
                Set simplex(i) = f.Eval(diff)
            Next i
        End If

        'Insert the new element in place
        If Not newFE Is Nothing Then
            For i = LBound(simplex) To UBound(simplex)
                If simplex(i).Result > newFE.Result Then
                    For j = UBound(simplex) To i + 1 Step -1
                        Set simplex(j) = simplex(j - 1)
                    Next j
                    Set simplex(i) = newFE
                    Exit For
                End If
            Next i
        End If

    Loop Until (simplex(UBound(simplex)).Result - simplex(LBound(simplex)).Result) < eps

    NelderMead = simplex(LBound(simplex)).VectArr

End Function

Function test(cube, guess) As Double

    Dim f As New Func
    Dim guessVec(0 To 0) As Double
    Dim Result() As Double
    Dim i As Integer
    Dim output As String

    f.cube = cube
    guessVec(0) = guess

    Result = NelderMead(f, guessVec)

    test = Result(0)

End Function

Func 类包含您的残差函数。 NelderMead 方法只需要 Func 类的 Result 方法，因此只要 Eval 方法处理与您初始猜测长度相同的向量并返回 FuncEval 对象，您就可以对 Func 类做任何事情。

调用测试函数来查看它的运行情况。注意，我还没有实际测试过多维向量，我要出去，有什么问题告诉我！

编辑：泛化函数传递的建议

您需要针对不同的问题创建许多不同的类。这意味着要保持 NelderMead 函数的通用性，您需要将其声明行更改为以下内容：

Function NelderMead(f As Object, _
                    ByRef guess() As Double) As Double()

无论 f 是什么，它必须始终有一个 Eval 方法，该方法接受一个双精度数组。

编辑：函数传递，可能是在 VBA 中完成的（愚蠢的）方式

Function f(x() As Double) As Double
    f = x(0) * x(0)
End Function

Sub Test()
    Dim x(0 To 0) As Double
    x(0) = 5
    Debug.Print Application.Run("f", x)
End Sub

使用此方法，您将拥有以下声明：

Function NelderMead(f As String, _
                    ByRef guess() As Double) As Double()

然后使用上面的 Application.Run 语法调用 f。您还需要在函数内部进行一些更改。它不漂亮，但坦率地说，它一开始并不那么漂亮。

【讨论】：

请注意，我并没有过多地关注效率（我开什么玩笑，它是 VBA，而不是 Haskell）或收敛条件。我建议您至少查看后者。

哇，这太棒了！我能够减少 pertFact 并且还没有任何收敛问题。我曾考虑编写自己的最小化程序，但我不确定是否可以在 VBA 中解决这个问题。我想现在我只需要让 Func 成为一个接口，这样我就可以制作许多不同的功能来最小化？通过阅读这段关于 VBA 工作原理的代码，我学到了很多东西。谢谢大家的帮助

很高兴你喜欢它:)。不幸的是，您需要为要最小化的每个函数创建一个新的 func 对象（不仅仅是一个实例，一个全新的类）。这样做的原因是除非你想解析一个函数字符串，否则我想不出任何方法在 VBA 中传递函数。使用 VBIDE 库可能有一些替代方案——或者你可以在这里发布另一个关于它的问题——事实上，我想我可能会这样做，出于兴趣。

这意味着您需要对代码进行更改。我已经编辑了我的答案以显示什么。

减少 pertfact 只是意味着您的初始“猜测窗口”更小。如果您想要更准确的答案，则需要减少 eps。请注意，如果将其减少得太远，可能会出现收敛问题和数值错误。通常 10^-12 是一个相当合理的值。

【参考方案2】：

您可以使用 Excel 附带的 Solver 插件来解决最小化问题。

【讨论】：

我最初也这么认为，但我认为除了 UDF 中公式所在的单元格之外，您不能更改任何单元格。如果您只想在电子表格上执行一次计算，求解器将起作用，但我需要在 VBA 中这样做，以便可以将其包含在我的 UDF 中。我可能弄错了，但有没有办法在没有单元格引用的情况下使用求解器？

我相信您可以在 UDF 中使用 Solver。试试这个链接peltiertech.com/Excel/SolverVBA.html

我看过这个，也许我没有看到如何使用它。我将尝试给出一个与我的更复杂和令人困惑的问题共享属性的问题的简化示例。