|
Sub test()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:i" & r)
For i = 2 To UBound(ar)
If Trim(ar(i, 3)) <> "" Then
nn = nn + 1
End If
Next i
If nn = "" Then Exit Sub
bl = .[l1]
If nn * bl = Int(nn * bl) Then
rs = nn * bl
Else
rs = Int(nn * bl) + 1
End If
Dim br()
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
p = Application.Rank(ar(i, 3), .Range("c2:c" & r))
If Val(p) <= rs Then
n = n + 1
d(Trim(ar(i, 1))) = ""
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
Dim arr()
ReDim arr(1 To d.Count, 1 To UBound(ar, 2) - 1)
For Each k In d.keys
m = m + 1
arr(m, 1) = k
For j = 3 To UBound(br, 2)
hj = 0: y = 0
For i = 1 To n
If Trim(br(i, 1)) = k And IsNumeric(br(i, j)) Then
y = y + 1
hj = hj + br(i, j)
End If
Next i
arr(m, j - 1) = hj / y
Next j
Next k
rr = .Cells(Rows.Count, 11).End(xlUp).Row + 10
.Range("k5:v" & rr) = Empty
.[k5].Resize(m, UBound(arr, 2)) = arr
End With
MsgBox "OK!"
End Sub
|
|