Question

您好我是VBA代码的新手，正在研究在Excel中的UDF内部进行一些非线性曲线拟合。我熟悉Matlab，我的大多数经验来自于。我正在寻找一个Sub / Function，它将为我提供类似于Matlab的fminsearch（）的功能。任何帮助，将不胜感激。感谢

编辑（2）以回应Brad

假设我想编写自己的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中解决这个问题的方法，但需要保留功能。谢谢你的病人。

Answer 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。您还需要在函数内部进行一些更改。它并不漂亮，但坦率地说，开始并不是那么好。

Answer 2

您可以使用Excel附带的Solver加载项来解决最小化问题。

寻找在VBA中使用的功能性最小化器

2 个答案: