[已解决]EXCEL中统计分析——在大数组集中寻找最稳态、斜率最小的小数组

香川群子

在Q1单元格中输入精度系数，可以调整截取L段的大小。

精度系数设置为0.2时，计算得到L段占比约 30%
精度系数设置为0.12-0.19时，计算得到L段占比约 19%
精度系数设置为0.1时，计算得到L段占比约 6%

香川群子

就楼主这次提供的数据来说，可能以下参数较好：

截取范围： 339 - 544 = 206 行 (密度占比44.2%)
设置参数： 间隔n1=2、步长n2=5、精度r2=1

在上述区间范围内，得到直线表达式： y = 0.000778 * x + 0.487161


附件中各个参数改为在代码外的单元格内设置调整的方式。
可调整参数的设置：
① 单元格N1内： 间隔n1 缺省=5 设置范围为>0的整数
含义：【自当前行间隔n1开始计算斜率k，忽略最近的误差较大的(n1-1)个点】

② 单元格O1内：步长n2 缺省=20 设置范围为>=n1的整数
含义：【自当前行间隔n1开始计算斜率k直到n2为止，共计算(n2-n1+1)个斜率，求斜率平均值】
以这样的方式，可以尽可能地得到涵盖较广范围的准确斜率

③ 单元格Q1内：精度系数r2 缺省=1
根据上述计算得到的各个点的对应平均斜率，
把它们之间的误差精度范围在r2系数以内的斜率值作为相同来合并归类，以便统计最多个数的斜率值。

r2的设置范围及效果：
r2为小数时，数值越小精度要求越高。
r2=1时，精度和小数点有效位数r一致 （当前r设置为=5，即计算取小数点后5位数进行VBA的四舍五入）
r2>1时，精度范围放大……
…………

计算结果中，密度占比44.2% 表示：
截取范围s1-s2对应的x轴范围 ar(s1, 1) - ar(s2, 1)在整个有效x轴范围内的占比密度。

这个计算值时很好的一个评价。反映了L段长度的有效范围。

香川群子

代码及简要说明：

1. Sub RsltClear() '清空E列、F列记录
   
2.     Range("E5").Resize(Range("E65536").End(3).Row) = ""
   
3.     Range("F5").Resize(Range("F65536").End(3).Row) = ""
   
4. End Sub
   
5. 
   
6. Sub kagawa() '香川直线拟合计算程序
   
7.     tms = Timer
   
8.    
   
9.     n1 = Range("N1"): If n1 = 0 Then n1 = 5: Range("N1") = n1
   
10. '    n1 = n1 + 1: Range("N1") = n1 '自动迭代测试
    
11.     n2 = Range("O1"): If n2 = 0 Then n2 = 20: Range("O1") = n2
    
12. '    n2 = n1 + 10: Range("O1") = n2 '自动迭代测试
    
13.     If n2 < n1 Then n2 = n1: Range("O1") = n2
    
14.    
    
15.     r = 5
    
16.     r2 = Range("Q1"): If r2 = 0 Then r2 = 1: Range("Q1") = r2
    
17. '     r2 = r2 - 0.1: Range("Q1") = r2 '自动迭代测试
    
18.      
    
19.     m = Range("A1").End(4).Row
    
20.     ar = Range("A1").Resize(m, 2)
    
21.    
    
22.     ReDim kr(3 To m)
    
23.     For i = 3 To m - n2
    
24.         t = 0
    
25.         For j = i + n1 To i + n2
    
26.             t = t + (ar(i, 2) - ar(j, 2)) / (ar(i, 1) - ar(j, 1))
    
27.         Next
    
28.         t = Round(t / (n2 - n1 + 1), r): kr(i) = t
    
29.         If Abs(t - t1) <= r2 * 10 ^ (1 - r) Then
    
30.             k = k + 1
    
31.         Else
    
32.             If k > k1 Then k1 = k: s1 = s: s2 = i - 1: t2 = t1
    
33.             k = 1: t1 = t: s = i
    
34.         End If
    
35.     Next
    
36. '    Debug.Print s1 & " - " & s2 & ",  k = " & t2
    
37.     '到此为止先按参数设置进行每个点的斜率计算，并求得精度范围内最大起始区间及对应斜率t2
    
38. 
    
39.     '下面以该斜率为基准值重新进行有效精度范围内的检查
    
40.     t3 = t2
    
41.     For i = 3 To m - n2
    
42.         t = kr(i)
    
43.         If Abs(t - t3) <= r2 * 10 ^ (1 - r) Then
    
44.             k = k + 1
    
45.         Else
    
46.             If k > k1 Then k1 = k: s1 = s: s2 = i - 1: t2 = t1
    
47.             k = 1: t1 = t: s = i
    
48.         End If
    
49.     Next
    
50. '    Debug.Print s1 & " - " & s2 & ",  k = " & t2
    
51.     '这样就得到了最终的精确起始区间，以及最终的有效拟合斜率k
    
52. 
    
53.     '下面根据此确定斜率k 计算拟合偏移量b的平均值
    
54.     t1 = t2: t2 = 0
    
55.     For i = s1 To s2
    
56.         t = kr(i)
    
57.         If t < t1 Then t1 = t
    
58.         If t > t3 Then t3 = t
    
59.         t2 = t2 + t
    
60.         kr(i) = Round(t, r - 1)
    
61.     Next
    
62.     t2 = Round(t2 / (s2 - s1 + 1), r + 1): Range("D2") = t2
    
63. '    Debug.Print s1 & " - " & s2 & ",  k = " & t2 & "/" & t1 & "/" & t3
    
64.     Range("D3").Resize(m - 2) = WorksheetFunction.Transpose(kr)
    
65.     '下面对截取区间内的斜率值作图进行数据更新 (为直观此时的斜率值精度被降低一级Round(t, r - 1))
    
66.     If ThisWorkbook.Application.International(xlCountryCode) = 81 Then ActiveSheet.ChartObjects("僌儔僼 3").Activate
    
67.     If ThisWorkbook.Application.International(xlCountryCode) = 86 Then ActiveSheet.ChartObjects("图表 3").Activate
    
68.     ActiveChart.SeriesCollection(1).Formula = "=SERIES(Sheet2!R1C4,,Sheet2!R" & s1 - 40 & "C4:R" & s2 + 40 & "C4,1)"
    
69.     ActiveChart.Axes(xlValue).MinimumScale = Round(t1, r - 1) - 3 * 10 ^ (1 - r)
    
70.     ActiveChart.Axes(xlValue).MaximumScale = Round(t3, r - 1) + 2 * 10 ^ (1 - r)
    
71.     ActiveWindow.Visible = False
    
72.     Range("H1").Activate
    
73.    
    
74.     '下面根据得到的拟合斜率和拟合偏移量b计算截取区间内各个点的拟合值
    
75.     t3 = 0
    
76.     For i = s1 To s2
    
77.         t3 = t3 + ar(i, 2) - t2 * ar(i, 1)
    
78.     Next
    
79.     t3 = Round(t3 / (s2 - s1 + 1), r + 1): [c2] = t3
    
80.     t = "y = " & Format(t2, "0." & String(r + 1, "0")) & " * x + " & Format(t3, "0." & String(r + 1, "0"))
    
81.     Range("J1") = t: Range("F65536").End(3).Offset(1) = t
    
82. '    Debug.Print t
    
83.    
    
84.     ReDim cr(3 To m)
    
85.     For i = s1 To s2
    
86.         cr(i) = t2 * ar(i, 1) + t3
    
87.     Next
    
88.     Range("C3").Resize(m - 2) = WorksheetFunction.Transpose(cr)
    
89.     '最后输出计算结果到E列(截取范围、密度占比、以及各项设置参数)、F列(直线表达式)
    
90.     Range("E65536").End(3).Offset(1) = s1 & " - " & s2 & " = " & s2 - s1 + 1 & Format((ar(s2, 1) - ar(s1, 1)) / ar(m, 1), " (0.0%) ") & n1 & "/" & n2 & "/" & r2
    
91.     MsgBox Format(Timer - tms, "0.000s") & vbCr & s1 & " - " & s2 & " = " & s2 - s1 + 1 & Format((ar(s2, 1) - ar(s1, 1)) / ar(m, 1), " (0.0%) ") & n1 & "/" & n2 & "/" & r2 & vbCr & t
    
92. End Sub
    

复制代码

这样就很容易进行各种计算验证了。

香川群子 发表于 2014-9-3 09:47
代码及简要说明：这样就很容易进行各种计算验证了。

很感谢您的帮助，提出用众数，分组以及部分参数设置修改结果等想法寻找线性部分的方法。
不过我想要的是一种面对有三段（其中第二段是近似线性）连续的数据组去寻找第二段线性的数据范围，该方法具有通用性，最好不用设置参数的那种。
虽然这要求过高，对我自己感觉近乎不可能，曾经用过相关系数R，肖伟奈定理等正态检验线性数组，结果不尽人意，上网咨询大神有没有解决方法。
再次感谢 香川群子 的帮助！