数据形式:两列数据,时间,Y值。
实现功能:从Y值中找到极值,再找到正负相间的第二次极值(第二次的极值中间相隔了多个原始极值点)。然后以第二次的极值点为隔点,从第一个数据积分(梯形面积),累积积分,直至积分到了下一个极值点清零。
容易忽视:极值点的条件,凸凹点都得有;做大小关系时的精度,使用double,否则可能比较失败。
Sub 正负极值点积分()
Dim data_long As Long '数据行数长度
Dim i As Long
Dim j As Long
Dim num_Array As Long '第几个极值点
Dim Y_peakArray(1 To 107287) '原始极值点
Dim rownum_peakArray(1 To 107286) '原始极值点所在行数
Dim range_peak(0 To 250000) As Long '第二次极值点间隔距离
Dim test As Long
Dim k As Long
Dim a As Double
Dim b As Double
Dim c As Double
Dim sum As Double
num_Array = 1
sum = 0
data_long = 107286
test = 1
Application.ScreenUpdating = False '冻结屏幕,以防屏幕抖动
Application.DisplayAlerts = False
'寻找极值点
For i = 2 To data_long - 1
a = Sheet1.Range("b" & i - 1)
b = Sheet1.Range("b" & i)
c = Sheet1.Range("b" & i + 1)
If (b > a And b > c) Or (b < a And b < c) Then
Y_peakArray(num_Array) = b
rownum_peakArray(num_Array) = i
num_Array = num_Array + 1 '极值点个数=num_Array-1
' 测试,查看极值分布
' Sheet2.Range("a" & test) = b
' test = test + 1
End If
Next i
'寻找正负相间极值点
m = 0
range_peak(0) = 0
i = 2
k = 1
Do While i <= data_long '满足则执行,条件利用率太低,有待改进!
Do While Y_peakArray(k) * Y_peakArray(i) < 0 'k-i对应于极值点的行数差
range_peak(m + 1) = rownum_peakArray(i) - rownum_peakArray(k) '从第一个极值点出发,行数相减,第一个间距:range_peak(1),对应于初始数据的行数差
m = m + 1
k = i
Loop
i = i + 1 'i是累加的,从每个间隔的极值点+1开始走
Loop
'计算正负极值点积分
'm=总共的极值点-1
'开头数据
i = rownum_peakArray(1)
j = 1
For n = j To i - 1 Step 1 '实际运算到了i-1,但最后 n=i
sum = (Sheet1.Range("b" & n) + Sheet1.Range("b" & n + 1)) * (Sheet1.Range("a" & n + 1) - Sheet1.Range("a" & n)) / 2 + sum
Sheet1.Range("c" & n) = sum
Next n
sum = 0
j = i
'中间数据
'i = rownum_peakArray(1)
For num_Array = 1 To m '有m个间隔
i = range_peak(num_Array) + j
For n = j To i - 1 Step 1 '实际运算到了i-1,但最后 n=i
sum = (Sheet1.Range("b" & n) + Sheet1.Range("b" & n + 1)) * (Sheet1.Range("a" & n + 1) - Sheet1.Range("a" & n)) / 2 + sum
Sheet1.Range("c" & n) = sum
Next n
sum = 0
j = i
Next num_Array
'计算尾部部分,应用情况:最后一个不是极值点
For n = j To data_long - 1 '实际运算到了data_long Step,但最后 n=data_long Step+1
sum = (Sheet1.Range("b" & n) + Sheet1.Range("b" & n + 1)) * (Sheet1.Range("a" & n + 1) - Sheet1.Range("a" & n)) / 2 + sum
Sheet1.Range("c" & n) = sum
Next n
sum = 0
MsgBox "积分完成!"
Application.ScreenUpdating = True '解除冻结屏幕,成对使用
Application.DisplayAlerts = True
End Sub