考场安排分班级分栏分页生成新的工作表

hbszls

https://club.excelhome.net/forum ... =%B0%E0%BC%B6%B1%ED
代码来自于这个帖子。chxw68

分班级分栏分页生成新的工作表，麻烦帮忙看看，怎么设置行列的格式。谢谢！

ykcbf1100

你是想设置格式呢，还是生成表？生成表的代码chxw68老师写过了。

hbszls

ykcbf1100 发表于 2024-4-10 17:04
你是想设置格式呢，还是生成表？生成表的代码chxw68老师写过了。

按顺序生成表。但那个生成的表很乱，我不知道怎么改。

chxw68

修改好了。

hbszls

chxw68 发表于 2024-4-10 17:47
修改好了。

太感谢了，很完美！现在要做一个考室的门贴。蛇型排列的。麻烦有时间就帮忙看看。

chxw68

1. Sub kcmt()  '考场门贴
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     With Worksheets("设置")
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
12.         sz = .Range("a3").Resize(r - 2, c)
    
13.         For i = 1 To UBound(sz)
    
14.             d1(CStr(sz(i, 2))) = i
    
15.         Next
    
16.     End With
    
17.     With Worksheets("名单")
    
18.         .AutoFilterMode = False
    
19.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
20.         arr = .Range("a2:e" & r)
    
21.         For i = 1 To UBound(arr)
    
22.             ssh = CStr(arr(i, 4))
    
23.             If Not d.exists(ssh) Then
    
24.                 Set d(ssh) = CreateObject("scripting.dictionary")
    
25.             End If
    
26.             d(ssh)(i) = Empty
    
27.         Next
    
28. 
    
29.     End With
    
30.     With Worksheets("考场门贴")
    
31.         .Cells.Clear
    
32.         r = 1
    
33.         For Each aa In d.keys
    
34.             If d1.exists(aa) Then
    
35.                 Z = d1(aa)
    
36.                 hs = 0
    
37.                 ls = 0
    
38.                 For j = 4 To UBound(sz, 2)
    
39.                     If hs < sz(1, j) Then
    
40.                         hs = sz(1, j)
    
41.                     End If
    
42.                 Next
    
43.                 For j = UBound(sz, 2) To 4 Step -1
    
44.                     If Len(sz(Z, j)) <> 0 Then
    
45.                         ls = j - 3
    
46.                         Exit For
    
47.                     End If
    
48.                 Next
    
49.                 ReDim brr(1 To hs, 1 To ls)
    
50.                 m = 1
    
51.                 n = 1
    
52.                 s = -1
    
53.                 kk = d(aa).keys
    
54.                 For j = 4 To 3 + ls
    
55.                     For i = 1 To sz(Z, j)
    
56.                         s = s + 1
    
57.                         If s > UBound(kk) Then
    
58.                             GoTo 100
    
59.                         End If
    
60.                         brr(m, n) = "考号:" & arr(kk(s), 2) & vbLf & "姓名:" & arr(kk(s), 3) & vbLf & "座位号:" & arr(kk(s), 5)
    
61.                         If n Mod 2 = 1 Then
    
62.                             m = m + 1
    
63.                             If m > sz(Z, j) Then
    
64.                                 m = sz(Z, j + 1)
    
65.                                 n = n + 1
    
66.                             End If
    
67.                         Else
    
68.                             m = m - 1
    
69.                             If m < 1 Then
    
70.                                 m = 1
    
71.                                 n = n + 1
    
72.                             End If
    
73.                         End If
    
74.                     Next
    
75.                 Next
    
76. 100:
    
77.                 With .Cells(r, 1)
    
78.                     .Value = "教学质量监测第" & aa & "试室"
    
79.                     .Resize(1, ls).Merge
    
80.                     With .Font
    
81.                         .Name = "微软雅黑"
    
82.                         .Size = 18
    
83.                     End With
    
84.                     .HorizontalAlignment = xlCenter
    
85.                     .VerticalAlignment = xlCenter
    
86.                 End With
    
87.                 For j = 1 To UBound(brr, 2)
    
88.                     .Cells(r + 1, j).Value = "第" & j & "列"
    
89.                 Next
    
90.                 With .Cells(r + 1, 1).Resize(1, UBound(brr, 2))
    
91.                     .Borders.LineStyle = xlContinuous
    
92.                     With .Font
    
93.                         .Name = "微软雅黑"
    
94.                         .Size = 11
    
95.                         .Bold = True
    
96.                     End With
    
97.                     .HorizontalAlignment = xlCenter
    
98.                     .VerticalAlignment = xlCenter
    
99.                 End With
    
100.                 With .Cells(r + 2, 1).Resize(UBound(brr), UBound(brr, 2))
     
101.                     .Borders.LineStyle = xlContinuous
     
102.                     .Value = brr
     
103.                     With .Font
     
104.                         .Name = "微软雅黑"
     
105.                         .Size = 11
     
106.                     End With
     
107.                 End With
     
108.                 .Rows(r).Resize(2).RowHeight = 36
     
109.                 .Rows(r + 2).Resize(UBound(brr)).RowHeight = 63.75
     
110.                 r = r + 2 + UBound(brr)
     
111. 
     
112.             End If
     
113.         Next
     
114.     End With
     
115. 
     
116. End Sub
     

复制代码

chxw68

写好了。。

cai2532

很好，学习了。

hbszls

chxw68 发表于 2024-4-11 12:20
写好了。。

很感谢！好好学习了。

hbszls

hbszls 发表于 2024-4-11 17:25
很感谢！好好学习了。

感谢你的无私的帮助，怎么设置列宽，有时间感谢你能指导下。