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

Question

你好我是VBA代碼的新手，我正在做一些非線性曲線擬合，在Excel中的UDF內部進行。我對Matlab的大部分經驗都來自我熟悉。我正在尋找一個Sub/Function，它可以提供類似於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 

那麼這可能與解算器一起使用，通過改變輸入「根」這一功能的輸出設置爲零來找到任何數量的立方根。然而，這只是我需要在UDF中執行的一個步驟，我正在嘗試編寫這個輸出（在這種情況下是立方體根），我需要在我的UDF中使用它來最終計算最終輸出。然後我想使用相對引用來使用我的整體UDF來計算一系列輸入。我相信這需要在VBA中進行最小化，而不是引用單元格。在這種情況下，封裝函數將處理「root」的值並返回該值。它只有一個輸入是「rootCubed」，並且只是將它傳遞給myCubeRootSResd。因此，這將是這個樣子：

Function myCubeRootFinder(rootCubed as Double) as Double 

……. 

End Function 

任何幫助將是非常讚賞我一直在努力，現在找到一個簡單的解決方案，這一段時間，我只是還沒有找到任何人做這種類型的例子VBA中的數值最小化。

我意識到這可能不是在VBA中這樣做的方式，但功能需要保留。感謝您與我的病人。

Answer 1

您可以使用Excel附帶的求解器加載項來解決最小化問題。

Answer 2

好吧，我有一些樂趣。

創建一個名爲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 

和被稱爲函數功能類：

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。你也需要在函數內進行一些修改。這並不漂亮，但坦率地說，一開始並不漂亮。