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处理数据的时候,为了能更清晰的标示出满足特定条件的单元格,对单元格添加背景色是不错的选择.手工处理的方式简单快捷,但是当遇到大批量数据,就会特别的费时费力,而且不讨好(容易出错).通过 ...
随机推荐
- 常用的key和oid
1.FortiGate Template-Network-Office-Fortigate-Session Count:key,fgSysSesCount oid,.1.3.6.1.4.1.123 ...
- 使用mybatis-generator-core工具自动生成mybatis实体
我们可以使用mybatis-generator-core这个工具将数据库对象转换成mybatis对象,具体步骤如下. 1.mybatis-generator-core下载 下载地址:http://do ...
- spring cloud ribbon和feign的区别
spring cloud的Netflix中提供了两个组件实现软负载均衡调用:ribbon和feign. Ribbon 是一个基于 HTTP 和 TCP 客户端的负载均衡器 它可以在客户端配置 ribb ...
- RecyclerView的点击事件添加-------接口回调的形式添加
package com.example.recyclerviewdemo; import android.support.v7.widget.RecyclerView; import android. ...
- php使用pthreads v3多线程的抓取新浪新闻信息
我们使用pthreads,来写一个多线程的抓取页面小程序,把结果存到数据库里. 数据表结构如下: CREATE TABLE `tb_sina` ( `id` int(11) unsigned NOT ...
- go语言使用go-sciter创建桌面应用(七) view对象常用方法，文件选择，窗口弹出，请求
view对象的详细文档请看: https://sciter.com/docs/content/sciter/View.htm demo9.html代码如下: <!DOCTYPE html> ...
- 任意格式视频转MP4格式
下载ffmpeg解压,提取ffmpeg.exe 在mmfpeg.exe目录下新建批处理,内容如下 @echo off title 正在转换,mp4转换完成自动关闭 ffmpeg -i %1 -y -q ...
- 怎么隐藏服务器的IP地址？
服务器一般很少会使用公网地址,直接放置在互联网上使用. 一般是设置成局域网的私网地址,并通过路由器的端口映射,发布在互联网:内部的NAT转换,相当于隐藏了路由器,外网访问并不知道具体服务器的IP地址. ...
- target runtime apache v6.0 not defined解决
在加载别人的一个项目时,会报该错误,需要先在buildpath中remove v6的版本,再点击add library,选择server runtime,如果eclipse配置过Tomcat,可以选择 ...
- POJ3254或洛谷1879 Corn Fields
一道状压\(DP\) POJ原题链接 洛谷原题链接 很显然的状压,\(1\)表示种植,\(0\)表示荒废. 将输入直接进行状压,而要满足分配的草场是适合种草的土地,即是分配时的状态中的\(1\),在输 ...