

'仅按第一志愿来统计,否则还缺少条件。
Option Explicit
Sub abc()
Dim a, b, i, j, m, n, min, max
a = [a1].CurrentRegion.Resize(, 9).Value
b = Range("k2:k" & [k2].End(xlDown).Row).Value
ReDim c(1 To UBound(b), 1 To 6)
For i = 1 To UBound(b)
min = 10 ^ 10: max = -1
For j = 2 To UBound(a)
If b(i, 1) = a(j, 5) Then
If a(j, 3) = "男" Then n = 2 Else n = 3
c(i, 1) = c(i, 1) + 1: c(i, n) = c(i, n) + 1
c(i, 6) = c(i, 6) + a(j, 4)
If min > a(j, 4) Then min = a(j, 4)
If max < a(j, 4) Then max = a(j, 4)
End If
Next
If max > -1 Then
c(i, 4) = max: c(i, 5) = min
c(i, 6) = Round(c(i, 6) / (c(i, 2) + c(i, 3)), 1)
End If
Next
[m2].Resize(UBound(c), 6) = c
End Sub