|
|
Sub 上线统计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("总分表")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "总分表为空！": End
ar = .Range("a1:k" & r)
End With
With Sheets("上线")
br = .Range("a1:i5")
End With
ReDim arr(1 To UBound(ar), 1 To 10)
For i = 2 To UBound(ar)
If ar(i, 2) <> "" Then
t = d(ar(i, 2))
If t = "" Then
k = k + 4
d(ar(i, 2)) = k
t = k
arr(k - 3, 1) = ar(i, 2)
arr(k - 2, 1) = ar(i, 2)
arr(k - 1, 1) = ar(i, 2)
arr(k, 1) = ar(i, 2)
arr(k - 3, 2) = br(2, 1)
arr(k - 2, 2) = br(3, 1)
arr(k - 1, 2) = br(4, 1)
arr(k, 2) = br(5, 1)
End If
For j = 4 To UBound(ar, 2)
If ar(i, j) <> "" Then
If IsNumeric(ar(i, j)) Then
If ar(i, j) >= br(2, j - 2) Then
arr(t - 3, j - 1) = arr(t - 3, j - 1) + 1
End If
If ar(i, j) >= br(3, j - 2) Then
arr(t - 2, j - 1) = arr(t - 2, j - 1) + 1
End If
If ar(i, j) >= br(4, j - 2) Then
arr(t - 1, j - 1) = arr(t - 1, j - 1) + 1
End If
If ar(i, j) >= br(5, j - 2) Then
arr(t, j - 1) = arr(t, j - 1) + 1
End If
End If
End If
Next j
End If
Next i
With Sheets("上线统计表")
rs = .Cells(Rows.Count, 1).End(xlUp).Row
If rs >= 2 Then .Range("a2:k" & rs) = Empty
.[a2].Resize(k, UBound(arr, 2)) = arr
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-2-24 14:13
