[發問] 有关Excel求微积分的问题

loquat

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

关于二维以及多维积分，不知道有哪位大牛能做出案例来，供大家参考。。。。

loquat

占楼，将来汇总或粘贴一维积分自定义函数
'辛普生积分法
'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)
   
10. 
    
11.   Dim i As Long
    
12.   Dim J As Long
    
13. 
    
14.   Dim X_VAL As Double
    
15. 
    
16.   Dim S1_VAL As Double
    
17.   Dim S2_VAL As Double
    
18.   Dim S3_VAL As Double
    
19.   Dim S4_VAL As Double
    
20. 
    
21.   Dim Delta_VAL As Double
    
22.   Dim Result_VAL As Double
    
23. 
    
24.   On Error GoTo ERROR_HANDEL_LABEL
    
25. 
    
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)
    
30. 
    
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
    
49. 
    
50.   Simpson_Integral_Func = Result_VAL
    
51. 
    
52.   Exit Function
    
53. ERROR_HANDEL_LABEL:
    
54.   Simpson_Integral_Func = Err.Number
    
55. End Function

複製代碼

loquat

矩形公式，待修改为自定义函数

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

矩形积分

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

4#的

1. r.Value

複製代碼

需要改为

1. r

複製代碼

loquat

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

複製代碼

其中复化辛普生积分公式效率最高。
还在研究其他更搞笑的计算方法。。