|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub test()
Dim i, j, k, arr, sum, m, a, p
arr = [a1].CurrentRegion.Offset(1)
ReDim brr(1 To UBound(arr, 1) - 1, 1 To 3)
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 2) <> arr(j + 1, 2) Then
If j > i Then Call dsort(arr, i, j, 1, True)
p = i
For k = i To j
If arr(k, 1) <> arr(k + 1, 1) Or k = j Then
Call dsort(arr, p, k, 5, False)
sum = 0
For a = p To k
sum = sum + arr(a, 5)
If a - p = 4 Then Exit For
Next
m = m + 1: brr(m, 1) = arr(p, 1)
brr(m, 2) = arr(p, 2): brr(m, 3) = Round(sum / 5, 1)
p = k + 1
End If
Next
i = j: Exit For
End If
Next j, i
Call dsort(brr, 1, m, 1, True)
With [g2]
.Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
.Resize(m, UBound(brr, 2)) = brr
End With
End Sub
Function dsort(arr, first, last, key, order)
Dim i, j, k, t
For i = first To last - 1
For j = i + 1 To last
If arr(i, key) < arr(j, key) Xor order Then
For k = 1 To UBound(arr, 2)
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
End If
Next j, i
End Function |
|