寻找在VBA中使用的函数最小化
您好,我是VBA代码的新手,正在excel中的UDF中进行一些非线性曲线拟合。我熟悉Matlab,我的大部分经验都来自于Matlab。我正在寻找一个子/函数,它将为我提供与Matlab中的fminsearch()类似的功能。任何帮助都将不胜感激。谢谢 编辑(2)以响应Brad 假设我想写我自己的UDF,它使用最小化迭代地找到一个数字的立方根。我可以写下面的函数吗寻找在VBA中使用的函数最小化,vba,excel,Vba,Excel,您好,我是VBA代码的新手,正在excel中的UDF中进行一些非线性曲线拟合。我熟悉Matlab,我的大部分经验都来自于Matlab。我正在寻找一个子/函数,它将为我提供与Matlab中的fminsearch()类似的功能。任何帮助都将不胜感激。谢谢 编辑(2)以响应Brad 假设我想写我自己的UDF,它使用最小化迭代地找到一个数字的立方根。我可以写下面的函数吗 Function myCubRootSResd(root As Double, rootCubed As Double) As Dou
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中这可能不是实现这一点的方法,但需要保留功能。谢谢你和我在一起 您可以使用Excel附带的Solver插件来解决问题。好的,我玩得很开心 创建名为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
无论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()
然后使用应用程序调用f。运行上面的语法。您还需要在函数内部进行一些更改。它并不漂亮,但坦率地说,一开始就没那么漂亮。我最初也这么认为,但我认为除了公式所在的单元格外,不能从UDF中更改任何单元格。如果您只想在电子表格上执行一次计算,则解算器将起作用,但我需要在VBA中这样做,以便可以将其包含在我的UDF中。我可能弄错了,但是有没有一种方法可以在不使用单元格引用的情况下使用解算器?我相信您可以在UDF中使用解算器。试试这个链接,我已经看过了,也许我不知道如何使用它。我将尝试给出一个简化的问题示例,该问题与我的更复杂、更混乱的问题具有相同的属性。今天晚些时候(当我有时间时),我会回来看看我是否能在解算器的上下文中回答这个问题,但是Matlab的fminsearch函数使用了Nelder-Mead方法,这实际上非常简单,可能是由大学一年级或二年级的学生编码的。更好的是:请注意,我没有太过关注效率(我会跟谁开玩笑,这是VBA,不是Haskell)或收敛条件。我建议你至少复习一下后者。哇,这太棒了!我能够减少这一事实,并且还没有任何收敛问题。我曾考虑过编写自己的最小化程序,但我不确定是否可以在VBA中解决这个问题。我想现在我只需要让Func成为一个接口,这样我就可以让manny的不同函数最小化?通过阅读这段关于VBA如何工作的代码,我学到了很多东西。谢谢你的帮助很高兴你喜欢:)。不幸的是,您需要为每个要最小化的函数创建一个新的func对象(不仅仅是一个实例,一个全新的类)。原因是,除非您想解析函数字符串,否则我想不出任何方法在VBA中传递函数。使用VBIDE库可能有其他选择,或者你可以在这里发布另一个关于它的问题,事实上,出于兴趣,我想我可能会这样做。这意味着你需要对代码进行更改。我已经编辑了我的答案来说明什么。减少事实只是意味着你最初的“猜测窗口”变小了。如果你想要一个更准确的答案,你需要减少每股收益。但请注意,如果将其减少得太多,可能会出现收敛问题和数值错误。通常10^-12是一个相当合理的值。
Function NelderMead(f As String, _
ByRef guess() As Double) As Double()