Board logo

標題: [發問] 有关Excel求微积分的问题 [打印本頁]
作者: loquat    時間: 2013-2-21 19:47     標題: 有关Excel求微积分的问题

一维积分目前已经有ExcelHome的chenjun大牛写过一个帖子
他本人使用宏表函数Evaluate制作了两个案例
将之写成VBA自定义函数，是我近期想做的事

关于二维以及多维积分，不知道有哪位大牛能做出案例来，供大家参考。。。。
作者: loquat    時間: 2013-2-21 20:51

占楼，将来汇总或粘贴一维积分自定义函数
'辛普生积分法
'FUNC_STR_NAME为函数名
  1. '================================
  2. ' 辛普森积分法
  3. ' Simpson_Integral_Func
  4. ' http://www.cnhup.com
  5. '================================
  6. Function Simpson_Integral_Func( _
  7.    ByRef Lower_Bound As Double, _
  8.    ByRef Upper_Bound As Double, _
  9.    Optional ByRef epsilon As Double = 2 ^ -52)

  11.   Dim i As Long
  12.   Dim J As Long

  14.   Dim X_VAL As Double

  16.   Dim S1_VAL As Double
  17.   Dim S2_VAL As Double
  18.   Dim S3_VAL As Double
  19.   Dim S4_VAL As Double

  21.   Dim Delta_VAL As Double
  22.   Dim Result_VAL As Double

  24.   On Error GoTo ERROR_HANDEL_LABEL

  26.   S3_VAL = 1#
  27.   Delta_VAL = Upper_Bound - Lower_Bound
  28.   S1_VAL = FUNC_STR_NAME(Lower_Bound) + _
  29.      FUNC_STR_NAME(Upper_Bound)

  31.   i = 0
  32.   Do
  33.     S4_VAL = S3_VAL
  34.     Delta_VAL = Delta_VAL / 2#
  35.     S2_VAL = 0#
  36.     X_VAL = Lower_Bound + Delta_VAL
  37.     J = 0
  38.     Do
  39.     S2_VAL = S2_VAL + 2# * FUNC_STR_NAME(X_VAL)
  40.     X_VAL = X_VAL + 2# * Delta_VAL
  41.     J = J + 1
  42.     Loop Until Not X_VAL < Upper_Bound
  43.     S1_VAL = S1_VAL + S2_VAL
  44.     S3_VAL = (S1_VAL + S2_VAL) * Delta_VAL / 3#
  45.     X_VAL = Abs(S4_VAL - S3_VAL) / 15#
  46.     i = i + 1
  47.   Loop Until Not X_VAL > epsilon
  48.   Result_VAL = S3_VAL

  50.   Simpson_Integral_Func = Result_VAL

  52.   Exit Function
  53. ERROR_HANDEL_LABEL:
  54.   Simpson_Integral_Func = Err.Number
  55. End Function
複製代碼
作者: loquat    時間: 2013-2-22 11:00

矩形公式，待修改为自定义函数
  1. Sub 求定积分()
  2.     On Error Resume Next
  3.     Dim n1 As Integer, n As Integer, i As Integer
  4.     Dim s As String
  5.     Dim C1 As Double, C2 As Double, C3 As Double
  6.     If ActiveSheet.UsedRange.Rows.Count < 2 Then
  7.         Cells(1, 1) = "积分式"
  8.         Cells(1, 2) = "下限"
  9.         Cells(1, 3) = "上限"
  10.         Cells(1, 4) = "计算结果"
  11.         s = MsgBox("请从第二行开始，每一行可计算一个积分，" & Chr(13) & "第一列输入积分式，积分变量只能用X，" & Chr(13) & "并且要按照Excel公式的要求输入", , "提示信息")
  12.     End If
  13.     n = ActiveSheet.UsedRange.Rows.Count
  14.     Columns(5).Hidden = True
  15.     For n1 = 2 To ActiveSheet.UsedRange.Rows.Count
  16.         s = Cells(n1, 1)
  17.         C1 = Cells(n1, 2) '积分下限
  18.         C2 = Cells(n1, 3) '积分上限
  19.         If s = "" Or C1 = 0 And C2 = 0 Then GoTo w1
  20.         s = UCase(s) '小写变大写
  21.         n = InStr(s, "X")
  22.         Do While n > 0
  23.             s = Left(s, n) & " " & Mid(s, n + 1)
  24.             Mid(s, n) = "e2"
  25.             n = InStr(s, "X")
  26.         Loop
  27.         Cells(n1, 4) = "=" & s
  28.         n = 2000 '小于32767,N值越大,结果越精确
  29.         C3 = (C2 - C1) / n
  30.         Cells(n1, 5) = C1
  31.         C2 = Cells(n1, 4) / 2
  32.         For i = 1 To n
  33.             Cells(n1, 5) = i * C3 + C1
  34.             C2 = C2 + Cells(n1, 4)
  35.         Next i
  36.         Cells(n1, 4) = (C2 - Cells(n1, 4) / 2) * C3
  37. w1:     Beep
  38.     Next n1
  39. End Sub
複製代碼
作者: loquat    時間: 2013-2-22 17:35

本帖最後由 loquat 於 2013-2-22 17:37 編輯

矩形积分
  1. Public Function 矩形积分(r As String, a As Double, b As Double, n As Integer) As Double
  2. Dim dx As Double
  3. dx = (b - a) / n
  4. For i = 1 To n
  5.     矩形积分 = 矩形积分 + Evaluate(Replace(r.Value, "x", (a + dx * (i - 1)))) * dx
  6. Next i
  7. End Function
複製代碼
梯形积分
  1. Public Function 梯形积分(r As String, a As Single, b As Single, n As Integer) As Double
  2. Dim dx As Double
  3. dx = (b - a) / n
  4. For i = 1 To n
  5.     梯形积分 = 梯形积分 + Evaluate(Replace(r.Value, "x", (a + dx * (i - 1 / 2)))) * dx
  6. Next i
  7. End Function
複製代碼
以上函数，r为函数关系式，a为积分下限，b为积分上限，n为分割次数，n不得大于32766
作者: loquat    時間: 2013-2-22 17:42

4#的
  1. r.Value
複製代碼
需要改为
  1. r
複製代碼
作者: loquat    時間: 2013-2-22 19:51

  1. Public Function 复化梯形积分(r As String, a As Single, b As Single, n As Integer) As Double
  2. Dim dx As Double, i As Integer
  3. dx = (b - a) / n
  4. 复化梯形积分 = (Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))) / 2
  5. For i = 1 To n - 1
  6.     复化梯形积分 = 复化梯形积分 + Evaluate(Replace(r, "x", (a + i * dx)))
  7. Next i
  8. 复化梯形积分 = 复化梯形积分 * dx
  9. End Function
複製代碼
  1. Public Function 辛普生积分(r As String, a As Single, b As Single, n As Integer) As Double
  2. Dim dx As Double, i As Integer, m As Integer
  3. m = 2 * n
  4. dx = (b - a) / m
  5. 辛普生积分 = Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))
  6. For i = 2 To m Step 2
  7.     辛普生积分 = 辛普生积分 + Evaluate(Replace(r, "x", (a + dx * (i - 1)))) + 2 * Evaluate(Replace(r, "x", (a + dx * i)))
  8. Next i
  9. 辛普生积分 = 辛普生积分 * dx * 2 / 3
  10. End Function
複製代碼
  1. Public Function 复化辛普生积分(r As String, a As Single, b As Single, n As Integer) As Double
  2. Dim dx As Double, i As Integer, m As Integer
  3. m = 2 * n
  4. dx = (b - a) / m
  5. 复化辛普生积分 = Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))
  6. For i = 2 To m Step 2
  7.     复化辛普生积分 = 复化辛普生积分 + 4 * Evaluate(Replace(r, "x", (a + dx * (i - 1)))) + 2 * Evaluate(Replace(r, "x", (a + dx * i)))
  8. Next i
  9. 复化辛普生积分 = (复化辛普生积分 - 2 * Evaluate(Replace(r, "x", (a + dx * m)))) * dx / 3
  10. End Function
複製代碼
其中复化辛普生积分公式效率最高。
还在研究其他更搞笑的计算方法。。



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)