excel中vba求摩尔圆包线
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer Sub readExcelToArr()
b = : f = : df = : dk = 0.0000001: db = 0.0000001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row
ReDim oxy(iRow - ), R(iRow - )
For i = To UBound(oxy) +
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next
k = (R(iRow - ) - R()) / Sqr(((oxy(iRow - ) - oxy()) ^ - (R(iRow - ) - R()) ^ )) 'Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
'MsgBox k
'f = computeF(k, b)
Do While df > dk
df =
'判断k
k1 = k + 0.0000001
k2 = k - 0.0000001
f1 = computeF(k1, b)
f2 = computeF(k2, b)
df = f1 - f2
If f1 > f2 Then
k = k2
Else
k = k1
End If
'判断b
b1 = b + db
b2 = b - db
f1 = computeF(k, b1)
f2 = computeF(k, b2)
If f1 > f2 Then
b = b2
Else
b = b1
End If
df = df + (f1 - f2)
Loop
MsgBox k
End Sub Function computeF(k As Double, b As Double) As Double
Dim sum As Double
sum = #
For i = To UBound(oxy) -
sum = sum + ((k * oxy(i) + b) / (Sqr(k ^ + )) - R(i)) ^
Next i
computeF = sum
End Function
补充，还是不行：
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer Sub readExcelToArr()
b = : f = : df = : dk = 0.0000001: db = 0.0000001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row
ReDim oxy(iRow - ), R(iRow - )
For i = To UBound(oxy) +
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next
k = (R(iRow - ) - R()) / Sqr(((oxy(iRow - ) - oxy()) ^ - (R(iRow - ) - R()) ^ )) 'Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
'MsgBox k
'f = computeF(k, b)
Do While df > dk
k1 = k + 0.0000001
k2 = k - 0.0000001
f1 = computeF(k1, b)
f2 = computeF(k2, b)
df = f1 - f2
If f1 > f2 Then
k = k2
Else
k = k1
End If Loop
MsgBox k
End Sub Function computeF(k As Double, b As Double) As Double
Dim sum As Double
sum = #
For i = To UBound(oxy) -
sum = sum + ((k * oxy(i) + b) / (Sqr(k ^ + )) - R(i)) ^
Next i
computeF = sum
End Function
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer Sub readExcelToArr()
b = : f = : df = : k = 0.5: dk = 0.0000000000001: db = 0.0000000000001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row
ReDim oxy(iRow - ), R(iRow - )
For i = To UBound(oxy) +
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next
'k = (R(iRow - 2) - R(0)) / Sqr(((oxy(iRow - 2) - oxy(0)) ^ 2 - (R(iRow - 2) - R(0)) ^ 2)) 'Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
'MsgBox k
'f = computeF(k, b)
Do While df / > dk
df =
'判断k
k1 = k + dk
k2 = k - dk
f1 = computeF(k1, b)
f2 = computeF(k2, b)
df = Abs(f1 - f2)
If f1 > f2 Then
k = k2
f = f2
Else
k = k1
f = f2
End If
'判断b
b1 = b + db
b2 = b - db
f1 = computeF(k, b1)
f2 = computeF(k, b2)
If f1 > f2 Then
b = b2
f = f2
Else
b = b1
f = f2
End If
df = df + Abs(f1 - f2)
Loop
MsgBox "k=" & k & ", b=" & b & " f=" & f
End Sub Function computeF(k As Double, b As Double) As Double
Dim sum As Double
sum = #
For i = To UBound(oxy) -
sum = sum + ((k * oxy(i) + b) / (Sqr(k ^ + )) - R(i)) ^
Next i
computeF = sum
End Function
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer Sub readExcelToArr()
b = : f = : df = : k = 0.5: dk = 0.0000000000001: db = 0.0000000000001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row
ReDim oxy(iRow - ), R(iRow - )
For i = To UBound(oxy) +
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next
'k = (R(iRow - 2) - R(0)) / Sqr(((oxy(iRow - 2) - oxy(0)) ^ 2 - (R(iRow - 2) - R(0)) ^ 2)) 'Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
'MsgBox k
'f = computeF(k, b)
Do While df > dk
df =
'判断k
k1 = k + dk
k2 = k - dk
f1 = computeF(k1, b)
f2 = computeF(k2, b)
df = Abs(f1 - f2)
If f1 > f2 Then
k = k2
f = f2
Else
k = k1
f = f2
End If
'判断b
b1 = b + db
b2 = b - db
f1 = computeF(k, b1)
f2 = computeF(k, b2)
If f1 > f2 Then
b = b2
f = f2
Else
b = b1
f = f2
End If
df = df + Abs(f1 - f2)
Loop
MsgBox "k=" & k & ", b=" & b & " f=" & f
End Sub Function computeF(k As Double, b As Double) As Double
Dim sum As Double
sum = #
For i = To UBound(oxy) -
sum = sum + ((k * oxy(i) + b) / (Sqr(k ^ + )) - R(i)) ^
Next i
computeF = sum
End Function
下面用求组合各个圆的斜率的平均值作为最终的k值吧。
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer, j As Integer, num As Integer Sub readExcelToArr()
b = : f = : df = : k = : num = : dk = 0.0000000000001: db = 0.0000000000001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row ' iRow=5
ReDim oxy(iRow - ), R(iRow - ) 'oxy(4),共有0 1 2 3 这四个元素
For i = To UBound(oxy) + 'UBound(oxy)为数组 oxy 第一维上限，为4
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next i
For i = To UBound(oxy) -
For j = i + To UBound(oxy) -
num = num +
k = k + (R(j) - R(i)) / Sqr(((oxy(j) - oxy(i)) ^ - (R(j) - R(i)) ^ )) 'Sqr((R(j) - R(i)) / (2 * R(i)))
Next j
Next i
k = k / num
MsgBox k End Sub
发现这样求平均和线性规划差别挺大的。所以还是用线性规划吧。
Dim f As Double, f1 As Double, f2 As Double, df As Double, oxy() As Double, R() As Double, k As Double, k1 As Double, k2 As Double, b As Double, b1 As Double, b2 As Double
Dim dk As Double, db As Double Dim iRow As Long, i As Integer, j As Integer, num As Integer, ii As Integer Sub readExcelToArr()
b = : f = : df = : k = : num = : dk = 0.001: db = 0.001
'Sheets("图表名").Activate Sheets(图表编号).Activate
' Worksheets("Sheet1").Activate
' Charts("Chart1").Activate
' DialogSheets("Dialog1").Activate
Sheets("zbl强度包线").Activate
iRow = Cells(Rows.Count, ).End(xlUp).Row ' iRow=5
ReDim oxy(iRow - ), R(iRow - ) 'oxy(4),共有0 1 2 3 这四个元素
For i = To UBound(oxy) + 'UBound(oxy)为数组 oxy 第一维上限，为4
oxy(i - ) = Range("A" & i)
R(i - ) = Range("B" & i)
' Range("C" & i) = oxy(i - 2)
' Range("D" & i) = R(i - 2)
Next i
For i = To UBound(oxy) - '4-2
For j = i + To UBound(oxy) -
num = num +
k = k + (R(j) - R(i)) / Sqr(((oxy(j) - oxy(i)) ^ - (R(j) - R(i)) ^ )) 'Sqr((R(j) - R(i)) / (2 * R(i)))
Next j
Next i
k = k / num
'k = (R(iRow - 2) - R(0)) / Sqr(((oxy(iRow - 2) - oxy(0)) ^ 2 - (R(iRow - 2) - R(0)) ^ 2)) 'Sqr((R(iRow - 2) - R(0)) / (2 * R(0)))
f = computeF(k, b)
MsgBox "k=" & k & ", b=" & b & " f=" & f
ii =
Do While (df > dk And df > db Or ii = ) 'Do While (ii = 1000) '
num =
Do While df > dk
df =
'判断k
k1 = k + dk
k2 = k - dk
f1 = computeF(k1, b)
f2 = computeF(k2, b)
df = Abs(f1 - f2)
If f1 > f2 Then
k = k2
f = f2
Else
k = k1
f = f2
End If
num = num +
If num > Then
Exit Do
End If
Loop num =
Do While df > db
df =
'判断b
b1 = b + db
b2 = b - db
f1 = computeF(k, b1)
f2 = computeF(k, b2)
df = Abs(f1 - f2)
If f1 > f2 Then
b = b2
f = f2
Else
b = b1
f = f2
End If
If num > Then
Exit Do
End If
Loop
ii = ii +
Loop
f = computeF(k, b)
MsgBox "k=" & k & ", b=" & b & " f=" & f
End Sub
'
Function computeF(k As Double, b As Double) As Double
Dim sum As Double
sum = #
For i = To UBound(oxy) -
sum = sum + ((k * oxy(i) + b) / (Sqr(k ^ + )) - R(i)) ^
Next i
computeF = sum
End Function
上面代码比较适合b接近0的情况。
先给出备用方案，就是用自带的函数。
=(($F$2*D2+$G$2)/SQRT($F$2^2+1)-E2)^2+(($F$2*D3+$G$2)/SQRT($F$2^2+1)-E3)^2+(($F$2*D4+$G$2)/SQRT($F$2^2+1)-E4)^2+(($F$2*D5+$G$2)/SQRT($F$2^2+1)-E5)^2
上面的公式是在H2中输好的，然后执行下面的代码。需要先加载规划求解（https://zhidao.baidu.com/question/417984575.html）
Sub Mliner()
'
' Mliner Macro
' 线性规划
' '
Range("H2").Select
SolverOk SetCell,:="$H$2", MaxMinVal:=, ValueOf:="", yChange:="$F$2:$G$2"
SolverAdd CellRef,:="$F$2", Relation:=, ormulaText:=""
SolverAdd CellRef,:="$G$2", Relation:=, ormulaText:=""
SolverOk SetCell,:="$H$2", MaxMinVal:=, ValueOf:="", yChange:="$F$2:$G$2"
SolverSolve
End Sub
excel中vba求摩尔圆包线的更多相关文章
- excel中VBA的使用
遇到的问题 在工作中遇到了一点小小的问题,需要给我负责带的班级的同学们测试男生1000米,女生800米的成绩.表格是这样的: 体育成绩表 序号 班级 姓名 性别 男1000.女800 成绩 1 1 张 ...
- excel中vba将excel中数字和图表输出到word中
参考:https://wenku.baidu.com/view/6c60420ecc175527072208af.html 比如将选区变为图片保存到桌面: Sub 将选区转为图片存到桌面() Dim ...
- Excel中VBA进行插入列、格式化、排序
在数据分析中经常需要对数据进行排序.排名,观察指标排名变化情况,手工处理的话不是太困难,但经常使用,还是编写宏比较方便. 宏命令比较简单,不多解释,只说一下注意事项: 1.有合并单元格,比如列.行合并 ...
- Excel中VBA 连接 数据库 方法- 摘自网络
Sub GetData() Dim strConn As String, strSQL As String Dim conn As ADODB.Connection Dim ds As ADODB.R ...
- excel中VBA对多个文件的操作
添加引用 "Scripting.FileSystemObject" (Microsoft Scripting Runtime) '用于操作文件.目录 Sub 数据整理部分() ' ...
- Excel中的宏--VBA的简单例子
第一步:点击录制宏 第二步:填写宏的方法名 第三步:进行一系列的操作之后,关闭宏 第四步:根据自己的需要查看,修改宏 第六步:保存,一般是另存为,后缀名为.xlsm,否则宏语言不能保存. 到此为止恭喜 ...
- 如何在Excel中通过VBA快速查找多列重复的值
今天项目组的一个同事问我如何快速的找到一个Excel中第3列和第5列的值完全重复的值,我想了想虽然Excel中自带查找重复值的功能,但是好像只能对同一列进行比较,所以就写了一个VBA进行处理,VBA非 ...
- 用VBA计算WPS 表格ET EXCEL中的行数和列数的多重方法
用VBA计算WPS 表格ET EXCEL中的行数和列数 每种方法中上面的是Excel的行数,下面的是Excel的列数. 方法1: ActiveSheet.UsedRange.Rows.Count Ac ...
- VBA在Excel中的应用（一)：改变符合条件单元格的背景颜色
在使用excel处理数据的时候,为了能更清晰的标示出满足特定条件的单元格,对单元格添加背景色是不错的选择.手工处理的方式简单快捷,但是当遇到大批量数据,就会特别的费时费力,而且不讨好(容易出错).通过 ...
随机推荐
- TCP/IP中的四元组、五元组、七元组
四元组:源IP地址.目的IP地址.源端口.目的端口 五元组:源IP地址.目的IP地址.源端口.目的端口.传输层协议 七元组:源IP地址.目的IP地址.源端口.目的端口.传输层协议,服务类型以及接口索引
- RESTful接口规范
一. 什么是RESTful REST与技术无关,代表的是一种软件架构风格,REST是Representational State Transfer的简称,中文翻译为“表征状态转移” REST从资源的角 ...
- go语言中的strings常用函数和格式化输出
package main; import ( "fmt" "strings" ) type person struct { name string; age i ...
- c语言使用指针交换数值
练习题:将两个int类型数值交换 #include <stdio.h> void swap(int*,int*); int main(void){ , hex = 0x5f1043; sw ...
- 9.14 h5日记
9.14 ❤知识补充 margin的问题:margin:0 auto:可以解决元素在网页的居中问题(记得设置宽度) 1.css层叠样式表的问题 CSS的两个性质 (1)继承性 (2)层叠性 ...
- Linux移植之内核启动过程start_kernel函数简析
在Linux移植之内核启动过程引导阶段分析中从arch/arm/kernel/head.S开始分析,最后分析到课start_kernel这个C函数,下面就简单分析下这个函数,因为涉及到Linux的内容 ...
- 从matlab中导出下载到的轨迹数据
我从该网址(http://www.ee.cuhk.edu.hk/~xgwang/MITtrajsingle.html)下载到了一些轨迹数据. 网页中简单说明了轨迹数据的由来:原始数据是在一个停车场上方 ...
- windows netcdf vs 配置
程序中添加的头文件是netcdfcpp.h文件 ************************************************************************** ...
- 如何判断来访的IP是否是百度蜘蛛ip？
网站日志是可以真实体现网站的状态,通过网站日志我们可以清楚的看到网站每天有多少访客,每天有多少蜘蛛来抓取网站的数据,哪些数据被蜘蛛抓取了.哪些页面在请求数据的时候发现了错误.这些都是可以通过状态码来进 ...
- mount重新挂载为写模式
mount -o remount,rw -t yaffs2 /dev/block/mtdblock3 /system mount -o remount,rw -t rootfs rootfs /