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处理数据的时候,为了能更清晰的标示出满足特定条件的单元格,对单元格添加背景色是不错的选择.手工处理的方式简单快捷,但是当遇到大批量数据,就会特别的费时费力,而且不讨好(容易出错).通过 ...
随机推荐
- Python: 浅淡Python中的属性(property)
起源:项目过程中需要研究youtube_dl这个开源组件,翻阅其中对类的使用,对比c#及Delphi中实现,感觉Python属性机制挺有意思.区别与高级编程语言之单一入口,在类之属性这一方面,它随意的 ...
- XML 解析技术
xml 解析方式有两种: dom 解析和 sax 解析: 针对着两种解析方式,有三种解析器: sun公司的 jaxp dom4j 组织的 dom4j jdom 组织的 jdom dom 解析XML : ...
- Vs2015 c# 诊断工具查看程序的占用情况
windbg用着还不熟悉,dottrace 还要版权,着急查看程序的cpu 的使用情况,因为程序开启之后占用处理器资源较大,问题在哪里呢,于是点开了vs2015自带的诊断工具,以前偶尔打开过,没发现 ...
- C# System.Data.OracleClient requires Oracle client software version 8.1.7 or greater
好好的程序,突然出现了错误,原因是:System.Data.OracleClient requires Oracle client software version 8.1.7 or greater, ...
- 杭电1518 Square(构成正方形) 搜索
HDOJ1518 Square Time Limit: 10000/5000 MS (Java/Others) Memory Limit: 65536/32768 K (Java/Others) ...
- NC 日志文件注册
在实际开发中,例如接口向外系统发送数据,这些数据前台看不到,一般都是记录日志,然后在后台日志文件中查看.但是,用系统原本日志文件来看,有时会记录一些别的模块日志信息.所以,我们可以注册个自己的模块日志 ...
- virualbox问题
出不来64位虚拟系统 bios设置虚拟化可用 2.创建虚拟机 启动不了 提示 不能打开一个... 安装exten 扩张包 3.设备 -- 安装增强功能... 分辨率 设置成功
- Java中终止线程的三种方法
终止线程一般建议采用的方法是让线程自行结束,进入Dead(死亡)状态,就是执行完run()方法.即如果想要停止一个线程的执行,就要提供某种方式让线程能够自动结束run()方法的执行.比如设置一个标志来 ...
- 第一次java实验报告
实验一Java开发环境的熟悉-1 步骤: mkdir +20165213exp1创建20165213exp1这个目录 cd +20165213zqh进入这个目录 mkdir+src+bin创建目录sr ...
- Spring Environment（二）源码分析
Spring Environment(二)源码分析 Spring 系列目录(https://www.cnblogs.com/binarylei/p/10198698.html) Spring Envi ...