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处理数据的时候,为了能更清晰的标示出满足特定条件的单元格,对单元格添加背景色是不错的选择.手工处理的方式简单快捷,但是当遇到大批量数据,就会特别的费时费力,而且不讨好(容易出错).通过 ...
随机推荐
- jsp页面\n换行替换
1,js替换 var text= $(this).text(); var reg = new RegExp("\\n","g");//g,表示全部替换. tex ...
- mysql 数据库名称，中间带有中划线问题
插入数据时候,引用了数据库名,数据库名中有横线,会提示错误: You have an error in your SQL syntax; check the manual that correspon ...
- DialogActivity
<?xml version="1.0" encoding="utf-8"?> <resources> <style name=&q ...
- Dom,pull,Sax解析XML
本篇随笔将详细讲解如何在Android当中解析服务器端传过来的XML数据,这里将会介绍解析xml数据格式的三种方式,分别是DOM.SAX以及PULL. 一.DOM解析XML 我们首先来看看DOM(Do ...
- 基于kafka-net实现的可以长链接的消息生产者
今天有点时间,我就来说两句.最近接触的Kafka相关的东西要多一些,其实以前也接触过,但是在项目使用中的经验不是很多.最近公司的项目里面使用了Kafka消息中间件,由于以前的人员编写的客户端的类不是很 ...
- 2.git使用之git fetch和git push的区别
. git fetch:相当于是从远程获取最新版本到本地,不会自动merge git fetch origin master git log -p master..origin/master git ...
- SQL删除重复数据只保留一条数据
1.表结构与数据: CREATE TABLE tablezzl( id int, name ) ); 2.查询出重复的数据: 3.查询出要保留的重复数据: 4.最终的SQL: DELETE FROM ...
- c# 24种设计模式5原型模式（Prototype）
前言 原型模式其实C# Object中已经提供了一个Clone( )方法,平时很少用到,最近读Retrofit源码时候看到有这种使用方式. 定义 原型模式就是在系统clone()标记的基础上,对Clo ...
- CentOS 7安装配置Samba服务器
CentOS 7安装配置Samba服务器 CentOS 7下Samba服务器安装配置过程笔记. 假设我们有这样一个场景 共享名 路径 权限 SHAREDOC /smb/docs 所有人员包括来宾均可以 ...
- Mockplus3.5.0.1新增标注功能
Mockplus3.5.0.1版本中,新增了标注功能.多种标注模式,智能生成,随时查看.原型设计效率更高. Mockplus的标注功能有以下四种模式: 1.无选中标注 在未选中任何组件时,按住Ctrl ...