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处理数据的时候,为了能更清晰的标示出满足特定条件的单元格,对单元格添加背景色是不错的选择.手工处理的方式简单快捷,但是当遇到大批量数据,就会特别的费时费力,而且不讨好(容易出错).通过 ...
随机推荐
- FortiGate基本信息
1.介绍 FortiGate是全新的下一代防火墙,在整个硬件架构和系统上面都有新的设计,在性能和功能上面都有了很大提升,具有性能高.接口丰富.功能齐全.安全路由交换一体化.性价比高等优势. Forti ...
- 8.16 val()和html()的问题
今天在做关闭模态框重置表单时,关闭模态框后输入框里的值还是在,不知道怎么回事? 感谢wd啦,原来我在初始化这个输入框的时候就写错了,输入框写值的时候用的是val(),而我和上面的div一样,用的是ht ...
- Java03-Java语法基础（二）运算符
Java语法基础(二)运算符 一.运算符 1.算数运算符:+.-.*./.% 1)双目运算符:二元运算符,参加运算的对象有两个(+.-.*./.%) 2)单目运算符:一元运算符,参加运算的对象只有一个 ...
- 2019.3.15 关于IE
1. .clearfix {zoom:1} zoom:1 是ie浏览器专有属性 它可以设置或检索对象缩放比例 处理ie的hasLayout属性 清除浮动 清除margin的重叠
- subprocess.Popen在win10下会有异常
win10运行下 会报740错误 查了下搜索结果 是uac问题 但uac已经是关闭状态 后直接使用os.popen进行替换 运行ok
- 正则表达式 re sys os random time 模块
今天学习内容如下: 1.正则表达式 百度正则表达式在线测试,可以练习 正则表达式本身也和python没有什么关系,就是匹配字符串内容的一种规则.官方定义:正则表达式是对字符串操作的一种逻辑公式,就是用 ...
- Ionic3--数据存储
1.使用sqlite cordova plugin add cordova-sqlite-storage --save npm install --save @ionic/storage (本地存储) ...
- PHP——explode的应用（获取字符串，拆为下拉列表）
<?php //定义有默认值的函数 function Main3($f=5,$g=6) { echo $f*$g; } Main3(2,3); echo "<br />&q ...
- RPG难题
/* 人称“AC女之杀手”的超级偶像LELE最近忽然玩起了深沉,这可急坏了众多“Cole”(LELE的粉丝,即"可乐"),经过多方打探,某资深Cole终于知道了原因,原来,LELE ...
- Tinyos学习笔记（一）
简述:发送和接受数据的程序分别烧录到两个节点上,发送方发送流水灯数据,接受方接受数据并实现流水灯 1.发送和接受程序用到的组件及其接口如图(通过make telosb docs获得)所示: 2.发 ...