loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2013-2-21 19:47 | 只看該作者

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

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

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

梯形公式和辛普生公式.zip (42.75 KB)

一维积分

矩形公式法.zip (4.82 KB)

一维积分

向高手学习

loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

2^#

發表於 2013-2-21 20:51 | 只看該作者

占楼，将来汇总或粘贴一维积分自定义函数
'辛普生积分法
'FUNC_STR_NAME为函数名

'================================
' 辛普森积分法
' Simpson_Integral_Func
' http://www.cnhup.com
'================================
Function Simpson_Integral_Func( _
ByRef Lower_Bound As Double, _
ByRef Upper_Bound As Double, _
Optional ByRef epsilon As Double = 2 ^ -52)
Dim i As Long
Dim J As Long
Dim X_VAL As Double
Dim S1_VAL As Double
Dim S2_VAL As Double
Dim S3_VAL As Double
Dim S4_VAL As Double
Dim Delta_VAL As Double
Dim Result_VAL As Double
On Error GoTo ERROR_HANDEL_LABEL
S3_VAL = 1#
Delta_VAL = Upper_Bound - Lower_Bound
S1_VAL = FUNC_STR_NAME(Lower_Bound) + _
FUNC_STR_NAME(Upper_Bound)
i = 0
Do
S4_VAL = S3_VAL
Delta_VAL = Delta_VAL / 2#
S2_VAL = 0#
X_VAL = Lower_Bound + Delta_VAL
J = 0
Do
S2_VAL = S2_VAL + 2# * FUNC_STR_NAME(X_VAL)
X_VAL = X_VAL + 2# * Delta_VAL
J = J + 1
Loop Until Not X_VAL < Upper_Bound
S1_VAL = S1_VAL + S2_VAL
S3_VAL = (S1_VAL + S2_VAL) * Delta_VAL / 3#
X_VAL = Abs(S4_VAL - S3_VAL) / 15#
i = i + 1
Loop Until Not X_VAL > epsilon
Result_VAL = S3_VAL
Simpson_Integral_Func = Result_VAL
Exit Function
ERROR_HANDEL_LABEL:
Simpson_Integral_Func = Err.Number
End Function

複製代碼

向高手学习

TOP

loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

3^#

發表於 2013-2-22 11:00 | 只看該作者

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

Sub 求定积分()
On Error Resume Next
Dim n1 As Integer, n As Integer, i As Integer
Dim s As String
Dim C1 As Double, C2 As Double, C3 As Double
If ActiveSheet.UsedRange.Rows.Count < 2 Then
Cells(1, 1) = "积分式"
Cells(1, 2) = "下限"
Cells(1, 3) = "上限"
Cells(1, 4) = "计算结果"
s = MsgBox("请从第二行开始，每一行可计算一个积分，" & Chr(13) & "第一列输入积分式，积分变量只能用X，" & Chr(13) & "并且要按照Excel公式的要求输入", , "提示信息")
End If
n = ActiveSheet.UsedRange.Rows.Count
Columns(5).Hidden = True
For n1 = 2 To ActiveSheet.UsedRange.Rows.Count
s = Cells(n1, 1)
C1 = Cells(n1, 2) '积分下限
C2 = Cells(n1, 3) '积分上限
If s = "" Or C1 = 0 And C2 = 0 Then GoTo w1
s = UCase(s) '小写变大写
n = InStr(s, "X")
Do While n > 0
s = Left(s, n) & " " & Mid(s, n + 1)
Mid(s, n) = "e2"
n = InStr(s, "X")
Loop
Cells(n1, 4) = "=" & s
n = 2000 '小于32767,N值越大,结果越精确
C3 = (C2 - C1) / n
Cells(n1, 5) = C1
C2 = Cells(n1, 4) / 2
For i = 1 To n
Cells(n1, 5) = i * C3 + C1
C2 = C2 + Cells(n1, 4)
Next i
Cells(n1, 4) = (C2 - Cells(n1, 4) / 2) * C3
w1: Beep
Next n1
End Sub

複製代碼

向高手学习

TOP

loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

4^#

發表於 2013-2-22 17:35 | 只看該作者

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

矩形积分

Public Function 矩形积分(r As String, a As Double, b As Double, n As Integer) As Double
Dim dx As Double
dx = (b - a) / n
For i = 1 To n
矩形积分 = 矩形积分 + Evaluate(Replace(r.Value, "x", (a + dx * (i - 1)))) * dx
Next i
End Function

複製代碼

梯形积分

Public Function 梯形积分(r As String, a As Single, b As Single, n As Integer) As Double
Dim dx As Double
dx = (b - a) / n
For i = 1 To n
梯形积分 = 梯形积分 + Evaluate(Replace(r.Value, "x", (a + dx * (i - 1 / 2)))) * dx
Next i
End Function

複製代碼

以上函数，r为函数关系式，a为积分下限，b为积分上限，n为分割次数，n不得大于32766

向高手学习

TOP

loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

5^#

發表於 2013-2-22 17:42 | 只看該作者

4#的

r.Value

複製代碼

需要改为

r

複製代碼

向高手学习

TOP

loquat

中學生 Rank: 2

帖子: 48
主題: 1
精華: 0
積分: 53
點名: 0
作業系統: XP
軟體版本: 2010 & 2003
閱讀權限: 20
性別: 男
來自: China
註冊時間: 2013-1-12
最後登錄: 2013-11-23

6^#

發表於 2013-2-22 19:51 | 只看該作者

Public Function 复化梯形积分(r As String, a As Single, b As Single, n As Integer) As Double
Dim dx As Double, i As Integer
dx = (b - a) / n
复化梯形积分 = (Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))) / 2
For i = 1 To n - 1
复化梯形积分 = 复化梯形积分 + Evaluate(Replace(r, "x", (a + i * dx)))
Next i
复化梯形积分 = 复化梯形积分 * dx
End Function

複製代碼

Public Function 辛普生积分(r As String, a As Single, b As Single, n As Integer) As Double
Dim dx As Double, i As Integer, m As Integer
m = 2 * n
dx = (b - a) / m
辛普生积分 = Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))
For i = 2 To m Step 2
辛普生积分 = 辛普生积分 + Evaluate(Replace(r, "x", (a + dx * (i - 1)))) + 2 * Evaluate(Replace(r, "x", (a + dx * i)))
Next i
辛普生积分 = 辛普生积分 * dx * 2 / 3
End Function

複製代碼

Public Function 复化辛普生积分(r As String, a As Single, b As Single, n As Integer) As Double
Dim dx As Double, i As Integer, m As Integer
m = 2 * n
dx = (b - a) / m
复化辛普生积分 = Evaluate(Replace(r, "x", a)) + Evaluate(Replace(r, "x", b))
For i = 2 To m Step 2
复化辛普生积分 = 复化辛普生积分 + 4 * Evaluate(Replace(r, "x", (a + dx * (i - 1)))) + 2 * Evaluate(Replace(r, "x", (a + dx * i)))
Next i
复化辛普生积分 = (复化辛普生积分 - 2 * Evaluate(Replace(r, "x", (a + dx * m)))) * dx / 3
End Function

複製代碼

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

向高手学习

TOP

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

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

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]