楼主
芐雨 |
Q：如何列出数的密集分布并找出最接近预测值的覆盖率
A：
解决思路：
1.用循环列出所有解（即所有数组合的密集分布与覆盖率）。
2.找出（实际覆盖率-预测值）的绝对值的最小值。
3.若等于最小值，列出上限，下限和覆盖率。
代码如下：
- Sub 根据预测值找出最接近的覆盖率_芐雨()
- Dim i%, arr, ar, arP, arS, minP, arC
- Dim d As Object
- On Error Resume Next '防止点取消时出错
- Set d = CreateObject("Scripting.Dictionary")
- Set Rng = Application.InputBox("根据D2单元格的值求出最接近值" & Chr(10) & Chr(10) & "请选择数值区域", Title:="芐雨", Type:=8)
- arr = Rng
- Range("E1").Resize(65536, 255).Clear '消除单元格
- P = Range("D2") '设P为预测覆盖率
- For i = 1 To UBound(arr) '把数组放入字典中去重复，计个数
- For j = 1 To Rng.Count / UBound(arr)
- If arr(i, j) <> "" And IsNumeric(arr(i, j)) Then '跳过空单元格与非数值
- d(arr(i, j)) = d(arr(i, j)) + 1
- N = N + 1 '记录个数，作为分母,设为N
- End If
- Next
- Next
- k = d.keys: t = d.items 'k是各个不重复值，t是各个不重复值的个数
- ReDim ar(1 To 2 + d.Count, 1 To d.Count) '存放值，个数，与所有覆盖率
- ReDim arP(1 To d.Count, 1 To d.Count) '存放所有覆盖率与预测覆盖率的差的绝对值
- ReDim arS(1 To 3, 1 To d.Count * (d.Count + 1) / 2) 'd.Count * (d.Count + 1) / 2) 为所有组合覆盖率的个数
- ReDim arC(1, 1 To d.Count + 2)
- For i = 1 To d.Count
- ar(1, i) = Application.Small(k, i) '从小到大排序
- ar(2, i) = d(ar(1, i)) '对应该不重复值的个数
- ar(3, i) = d(ar(1, i)) / N '每个数的覆盖率
- arP(1, i) = Abs(ar(3, i) - P) '每个数的覆盖率与预测覆盖率的差的绝对值，设为arP
- Next i
- If d.Count = 1 Then GoTo AB '如果去重后是1行直接返回结果
- For j = 4 To d.Count + 2
- For i = 1 To d.Count
- ar(j, i) = ar(j - 1, i) + ar(3, i + j - 3) '求出每个组合的覆盖率
- arP(j - 2, i) = Abs(ar(j, i) - P) '每个组合的覆盖率与预测覆盖率的差的绝对值
- If i + j - 3 = d.Count Then Exit For '跳出循环
- Next
- Next
- AB:
- minP = Application.Min(arP, 1) '所有组合覆盖率与预测覆盖率的差的绝对值的最小值
- For i = 1 To d.Count
- For j = 1 To d.Count
- If i + j - 2 = d.Count Then Exit For '跳出循环
- If arP(i, j) = minP Then '判断是否等于最小值
- x = x + 1
- arS(1, x) = ar(1, j) '上限
- arS(2, x) = ar(1, j + i - 1) '根据j+i-1的大小判断下限
- arS(3, x) = ar(i + 2, j) '实际覆盖率
- End If
- Next
- Next
- For i = 1 To d.Count '设置标题
- Cells(1, i + 10) = i & "个数的覆盖率"
- Next
- Cells(1, 5) = "上限"
- Cells(1, 6) = "下限"
- Cells(1, 7) = "实际覆盖率"
- Cells(1, 9) = "数值"
- Cells(1, 10) = "个数"
- Range("I2").Resize(d.Count, 2 + d.Count) = Application.Transpose(ar) '列出所有组合的覆盖率
- Range("K2").Resize(d.Count, d.Count).NumberFormatLocal = "0.00%" '设置格式
- Range("E2").Resize(x, 3) = Application.Transpose(arS) '输出结果
- Range("G2").Resize(x).NumberFormatLocal = "0.00%" '设置格式
- End Sub
 根据预测值找出最接近的覆盖率_芐雨.rar
|
