|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 编排()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
y = .Cells(1, Columns.Count).End(xlToLeft).Column
If r < 2 Or y < 6 Then MsgBox "报名表为空！": End
ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 2)) <> "" And Trim(ar(i, 5)) <> "" Then
zd = Trim(ar(i, 2)) & Trim(ar(i, 5))
d(zd) = ""
End If
Next i
mrr = Array("第一道", "第二道", "第三道", "第四道", "第五道", "第六道", "第七道", "第八道")
srr = Array("号码", "姓名", "班级")
With Sheets("编排")
.UsedRange = Empty
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
zd = Trim(ar(i, 2)) & Trim(ar(i, 5))
If zd = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
For j = 6 To UBound(br, 2)
m = 0
ReDim cr(1 To n, 1 To 3)
For i = 1 To n
If Trim(br(i, j)) = "√" Then
m = m + 1
cr(m, 1) = br(i, 1)
cr(m, 2) = br(i, 3)
cr(m, 3) = br(i, 4)
End If
Next i
rs = .Cells(Rows.Count, 2).End(xlUp).Row + 1
If rs = 2 Then
rs = 1
Else
rs = rs
End If
.Cells(rs, 1) = k & ar(1, j)
.Cells(rs + 1, 2).Resize(1, 8) = mrr
If m <= 8 Then
.Cells(rs + 2, 2).Resize(1, m) = Application.Transpose(cr)
.Cells(rs + 2, 1).Resize(3, 1) = Application.Transpose(srr)
ElseIf m > 8 Then
h = rs + 2
For i = 1 To m Step 8
.Cells(h, 1) = "号码"
.Range("b" & h & ":i" & h).NumberFormatLocal = "000"
.Cells(h + 1, 1) = "班级"
.Cells(h + 2, 1) = "姓名"
lh = 1
For s = i To i + 7
lh = lh + 1
.Cells(h, lh) = cr(s, 1)
.Cells(h + 1, lh) = cr(s, 2)
.Cells(h + 2, lh) = cr(s, 3)
Next s
h = h + 3
Next i
End If
Next j
Next k
End With
MsgBox "ok!"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-10-28 09:48
楼主
