|
Sub test()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim br()
ar = Sheets("源数据").[a1].CurrentRegion
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) <> "" Then
d(Trim(ar(i, 1))) = d(Trim(ar(i, 1))) + 1
End If
Next i
Dim arr()
ReDim arr(1 To UBound(ar), 1 To 6)
For Each k In d.keys
n = 0: m = 0: m_1 = 0: m_2 = 0: m_3 = 0
er = 0: xh = 0: xx = 0: xxs = 0
t = t + 1
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If Trim(ar(i, 1)) = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
arr(t, 1) = k
arr(t, 2) = Application.Sum(Application.Index(br, 0, 13)) / d(k)
For i = 1 To n
If Trim(br(i, 7)) = "FDD" Then
m = m + 1
er = er + br(i, 9)
End If
If Trim(br(i, 7)) = "TDD" Then
m_1 = m_1 + 1
xh = xh + br(i, 12)
End If
If Trim(br(i, 8)) = "FDD900" And Trim(br(i, 6)) = "宏站" Then
m_2 = m_2 + 1
xx = xx + br(i, 14)
End If
If Trim(br(i, 8)) = "FDD900" And Trim(br(i, 6)) = "微站" Then
m_3 = m_3 + 1
xxs = xxs + br(i, 14)
End If
Next i
If m = 0 Then
arr(t, 3) = 0
Else
arr(t, 3) = er / m
End If
If m_1 = 0 Then
arr(t, 4) = 0
Else
arr(t, 4) = xh / m_1
End If
If m_2 = 0 Then
arr(t, 5) = 0
Else
arr(t, 5) = xx / m_2
End If
If m_3 = 0 Then
arr(t, 6) = 0
Else
arr(t, 6) = xxs / m_3
End If
Next k
With Sheets("效能")
.UsedRange.Offset(1) = Empty
.[a2].Resize(t, 6) = arr
End With
End Sub
|
|