楼主
kevinchengcw |
Q: 如何用vba代码对一曲线求出其包络线？
A: 思路如下：
根据循环源数据，根据数据前两项求出当前数据趋势方向（方向用于决定求取数据段的最大值还是最小值），根据当前加和值求出平均值，当数据方向为减少时，如果当前循环到的数据大于了当前的平均值，则认为数据减少段结束，从此段的起始位置到当前位置求出最小值及位置放入结果数组第一列；当数据方向为增加时，如果当前循环到的数据小于了当前的平均值，则认为数据增加段结束，从此段的起始位置到当前位置求出最大值及位置放入结果数组第二列。最后利用取得的各个结果之间的差与间隔数求出递增或递减的量，并逐一补进空白项中形成各数据点间的直线结果。
实现代码如下：
- Sub test()
- Dim Arr, Arrt(1 To 2) As Double, Result, N&, I&, A&, T#, Total#, Direct As Boolean, Dic As Object
- Arr = Range("b2:b" & Cells(Rows.Count, 2).End(3).Row).Value '取得源数据
- ReDim Result(LBound(Arr) To UBound(Arr), 1 To 2) '定义同样行数但两列的结果数组,第一列用于存储各数据减少段的最小值,第二列用于存储各数据增加段的最大值
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目用于存储增加或减少值对应的位置
- Direct = Arr(LBound(Arr), 1) >= Arr(LBound(Arr) + 1, 1) '以最开始两个数据的对比确定初始化方向变量的值
- Total = 0 '初始化加和值为0
- I = LBound(Arr) '初始化数据段起始点位置为数据第一项
- For N = LBound(Arr) To UBound(Arr) - 1 '循环数据段各项,因是两两比较,所以只循环到倒数第二项
- Total = Total + Arr(N, 1) '取得加和值
- If Direct Then '如果是减少的趋势,则
- If Arr(N, 1) > Total / N Then '如果当前项的值大于了平均值,则
- Direct = Not Direct '趋势反向(意味着当前趋势段结束)
- Arrt(1) = Arr(I, 1) '初始化本段最小值的数值为当前趋势的数据段第一项
- Arrt(2) = I '位置为当前趋势的数据段第一项的位置
- For A = I + 1 To N - 1 '循环当前趋势段
- If Arr(A, 1) < Arrt(1) Then '判断提取出最小值及位置赋值给数组
- Arrt(1) = Arr(A, 1)
- Arrt(2) = A
- End If
- Next A
- I = N '数据段起始位置调整到当前位置
- Result(Arrt(2), 1) = Arr(Arrt(2), 1) '将最小值及位置结果数据写入结果数组
- If Dic.exists(CStr(Direct)) Then '将对应位置存入字典中(以趋势逻辑值转化为文本作为key来储存)
- Dic(CStr(Direct)) = Dic(CStr(Direct)) & vbTab & Arrt(2)
- Else
- Dic.Add CStr(Direct), Arrt(2)
- End If
- End If
- Else '如果是增加的趋势,则操作基本同上,但找出的是最大值及位置
- If Arr(N, 1) < Total / N Then
- Direct = Not Direct
- Arrt(1) = Arr(I, 1)
- Arrt(2) = I
- For A = I + 1 To N - 1
- If Arr(A, 1) > Arrt(1) Then
- Arrt(1) = Arr(A, 1)
- Arrt(2) = A
- End If
- Next A
- I = N
- Result(Arrt(2), 2) = Arr(Arrt(2), 1)
- If Dic.exists(CStr(Direct)) Then
- Dic(CStr(Direct)) = Dic(CStr(Direct)) & vbTab & Arrt(2)
- Else
- Dic.Add CStr(Direct), Arrt(2)
- End If
- End If
- End If
- Next N
- Direct = True '提取出各个极值位置数据,取得其间的落差值及平均落差,依次补上数组空白项
- Arr = Split(Dic(CStr(Direct)), vbTab)
- For N = LBound(Arr) To UBound(Arr) - 1
- If Val(Arr(N + 1)) - Val(Arr(N)) > 1 Then
- T = Abs(Result(Val(Arr(N + 1)), 2) - Result(Val(Arr(N)), 2)) / (Val(Arr(N + 1)) - Val(Arr(N)))
- For I = 1 To Val(Arr(N + 1)) - Val(Arr(N)) - 1
- Result(Val(Arr(N)) + I, 2) = Result(Val(Arr(N)), 2) - I * T
- Next I
- If N = LBound(Arr) Then
- For I = 1 To Val(Arr(N)) - 1
- Result(I, 2) = Result(Val(Arr(N)), 2) + T * (Val(Arr(N)) - I)
- Next I
- ElseIf N = UBound(Arr) - 1 Then
- For I = Val(Arr(N + 1)) To UBound(Result)
- Result(I, 2) = Result(Val(Arr(N + 1)), 2) - T * (I - Val(Arr(N + 1)))
- Next I
- End If
- End If
- Next N
- Direct = Not Direct
- Arr = Split(Dic(CStr(Direct)), vbTab)
- For N = LBound(Arr) To UBound(Arr) - 1
- If Val(Arr(N + 1)) - Val(Arr(N)) > 1 Then
- T = Abs(Result(Val(Arr(N + 1)), 1) - Result(Val(Arr(N)), 1)) / (Val(Arr(N + 1)) - Val(Arr(N)))
- For I = 1 To Val(Arr(N + 1)) - Val(Arr(N)) - 1
- Result(Val(Arr(N)) + I, 1) = Result(Val(Arr(N)), 1) - I * T
- Next I
- If N = LBound(Arr) Then
- For I = 1 To Val(Arr(N)) - 1
- Result(I, 1) = Result(Val(Arr(N)), 1) + T * (Val(Arr(N)) - I)
- Next I
- ElseIf N = UBound(Arr) - 1 Then
- For I = Val(Arr(N + 1)) To UBound(Result)
- Result(I, 1) = Result(Val(Arr(N + 1)), 1) - T * (I - Val(Arr(N + 1)))
- Next I
- End If
- End If
- Next N
- [c2].Resize(UBound(Result), 2) = Result '结果数组写入工作表
- End Sub
以上代码在写时为了逻辑清晰,未进行优化,同时平均曲线方式会忽略掉小的波动,从而从大的趋势上得到几个极值的位置.
以上代码及思路希望大家进一步补充.
详见附件及素材源帖.
 Demo.rar
|