Sub 筛选标记()
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
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
.Range("h2:h" & r) = Empty
ar = .Range("a1:h" & r)
For i = 2 To UBound(ar)
If ar(i, 1) <> "" Then
w = ar(i, 1)
If Not d.exists(w) Then Set d(w) = CreateObject("scripting.dictionary")
d(w)(i) = ""
End If
Next i
ReDim brr(1 To d.Count * 2, 1 To 6)
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2) + 1)
m = m + 1
brr(m, 1) = k & "班"
For Each kk In d(k).keys
If ar(kk, 1) <> "" Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(kk, j)
Next j
br(n, UBound(br, 2)) = kk
End If
Next kk
For i = 1 To n
For s = i + 1 To n
If br(i, 4) > br(s, 4) Then
For j = 1 To UBound(br, 2)
mk = br(i, j)
br(i, j) = br(s, j)
br(s, j) = mk
Next j
End If
Next s
Next i
m = m + 1: y = 1
For s = 1 To 5
y = y + 1
brr(m, y) = br(s, 3)
ar(br(s, 9), 8) = "记号"
Next s
brr(m - 1, 2) = y - 1 & "人"
Next k
.Range("h1").Resize(UBound(ar), 1) = Application.Index(ar, 0, 8)
End With
With Sheets("标记名单下发")
.UsedRange = Empty
.[a1].Resize(m, UBound(brr, 2)) = brr
End With
MsgBox "ok!"
End Sub
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-9-28 20:09
