多语言展示
当前在线:627今日阅读:152今日分享:13

特征点拟合曲线【VBA】

有一条曲线是由很多个点组成,假设由于某种原因,不能使用到所有点,只使用其中的部分点来描述这条曲线的特征。
工具/原料

Excel

方法/步骤
1

原理大概如下,首先连接曲线的两个端点(1,2),连接一条直线,然后对曲线中间的各个点做这条曲线的垂直线,取最大的点(3),然后连接1-2,2-3形成两段折线。

2

然后将曲线上所有点向这段折线做垂直线取距离,距离最远的为第4点,然后连接4个点,形成了三段曲线,再次将曲线上的所有点向折线做垂直距离,取最远的为第5个点,依次类推,直至取出所需要的点。

3

因为涉及大量的重复执行内容,因此此方法只适用于使用编程方法实现,具体实现代码见下,VBA编程方法(VBA是什么?VBA是嵌套在Excel中的内置编程模块,具体自行网络查询)。

4

'记录第一个点和最后一个点的坐满到数组中;'首先用直线连接首点和末点,然后计算中间所有点到直线的垂直距离'选取所有距离中最大的一个点,记录为第三个点,然后将第三点更新到数组中'连接1、3,3、2,行成两条直线,然后再次比对所有数据点到直线的垂直距离'然后在所有点中,选取出最大的点,然后记为第四个点,更新到数组中'然后用直线连接四个点…依次类推,直至选取出10个点。Public myarr(1 To 10, 1 To 2)'定义全局变量数组Sub index()'主引导For i = 1 To 10    myarr(i, 1) = 0    myarr(i, 2) = 0Next'清除之前的数组缓存irow = Sheet1.Range('B65536').End(xlUp).Row'寻找数据总行数myarr(1, 1) = Sheet1.Cells(4, 7)'横坐标是棒位,纵坐标是功率myarr(1, 2) = Sheet1.Cells(4, 6)myarr(2, 1) = Sheet1.Cells(irow, 7)myarr(2, 2) = Sheet1.Cells(irow, 6)'初始化数组,定义前两个数组为首点和末点10 For i = 5 To irow - 1    x = Sheet1.Cells(i, 7)    '需要计算的每一个数据点的横坐标    y = Sheet1.Cells(i, 6)    '需要计算的每一个数据点的纵坐标    For n = 1 To 10    '然后在数据中选择对应的直线的端点        If x >= myarr(n, 1) Then            x1 = myarr(n - 1, 1)            y1 = myarr(n - 1, 2)            '前面一个端点的横纵坐标            x2 = myarr(n, 1)            y2 = myarr(n, 2)            '后面一个端点的横纵坐标            a = y2 - y1            b = x1 - x2            c = (x2 - x1) * y1 - (y2 - y1) * x1            '计算两个点所确定的直线方程中的A、B和C,即Ax+by+C=0形式            d = Abs((a * x + b * y + c) / (Sqr(a ^ 2 + b ^ 2)))            '根据公式计算点到直线的距离            Sheet1.Cells(i, 8) = d            '在第三列中显示距离            If d >= maxd Then                maxd = d                maxx = x                maxy = y                maxi = i                maxn = n            End If            '寻找距离中最大值            Exit For        End If    NextNextFor m = 10 To maxn + 1 Step -1       myarr(m, 1) = myarr(m - 1, 1)       myarr(m, 2) = myarr(m - 1, 2)       '要从大到小,将后面的统统往后移一位Next       myarr(maxn, 1) = Sheet1.Cells(maxi, 7)       myarr(maxn, 2) = Sheet1.Cells(maxi, 6)       '再将第n个点替换掉If myarr(10, 2) > 0 Then    For i = 1 To 10        Sheet1.Cells(i + 16, 10) = myarr(i, 1)        Sheet1.Cells(i + 16, 11) = myarr(i, 2)    Next    Exit SubElse    maxd = 0    maxx = 0    maxy = 0    maxi = 0    maxn = 0    GoTo 10End IfEnd Sub

5

数据的存放如下:

6

自动计算的结果作图如下,可见符合的很好:

推荐信息