求助根据考号自动生成各考室桌贴模板

飞起一脚

情况说明：
        由于各考室的人数不一样，打印完桌贴还需要根据各间考室的人数裁剪桌贴。比较麻烦。
        希望能通过工作表“考号”的内容，设置一个宏按钮，自动的将各考室的桌贴根据桌贴模板显示出来。注意考号的顺序不能乱。（一个考室一个工作表，下一个考室的信息能够与上一个考室的信息相连）
           谢谢！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim lk
   
5.   Dim d As Object
   
6.   Set d = CreateObject("scripting.dictionary")
   
7.   Application.ScreenUpdating = False
   
8.   Application.DisplayAlerts = False
   
9.   lk = [{8,38,9.63,8.50,9.63}]
   
10.   With Worksheets("考号")
    
11.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.     arr = .Range("a3:h" & r)
    
13.     For i = 1 To UBound(arr)
    
14.       If Not d.exists(arr(i, 5)) Then
    
15.         m = 1
    
16.         ReDim brr(1 To m)
    
17.       Else
    
18.         brr = d(arr(i, 5))
    
19.         m = UBound(brr) + 1
    
20.         ReDim Preserve brr(1 To m)
    
21.       End If
    
22.       brr(m) = i
    
23.       d(arr(i, 5)) = brr
    
24.     Next
    
25.   End With
    
26.   For Each aa In d.keys
    
27.     brr = d(aa)
    
28.     wjm = aa & "考室桌贴"
    
29.     On Error Resume Next
    
30.     Set ws = Worksheets(wjm)
    
31.     If Err Then
    
32.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
33.       ws.Name = wjm
    
34.     End If
    
35.     On Error GoTo 0
    
36.     With Worksheets(wjm)
    
37.       .Columns("a:i").NumberFormatLocal = "@"
    
38.       .Cells.Clear
    
39.       m = 1
    
40.       n = 1
    
41.       For i = 1 To UBound(brr)
    
42.         q = brr(i)
    
43.         .Cells(m, n).Resize(3, 1) = [{"姓名";"考室";"考号"}]
    
44.         .Cells(m, n + 2).Resize(2, 1) = [{"班级";"座号"}]
    
45.         .Cells(m, n + 1) = arr(q, 4)
    
46.         .Cells(m + 1, n + 1) = arr(q, 5)
    
47.         .Cells(m + 2, n + 1) = arr(q, 7)
    
48.         .Cells(m, n + 3) = arr(q, 8)
    
49.         .Cells(m + 1, n + 3) = arr(1, 7)
    
50.         With .Cells(m, n).Resize(3, 4)
    
51.           .Borders.LineStyle = xlContinuous
    
52.         End With
    
53.         n = n + 5
    
54.         If n > 6 Then
    
55.           m = m + 4
    
56.           n = 1
    
57.         End If
    
58.       Next
    
59.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
60.       With .Range("a:a,c:c,f:f,h:h")
    
61.         With .Font
    
62.           .Bold = True
    
63.         End With
    
64.       End With
    
65.       With .Range("a1:i" & r)
    
66.         With .Font
    
67.           .Size = 10
    
68.         End With
    
69.       End With
    
70.       .Rows("1:" & r).RowHeight = 14.25
    
71.       .Columns("a:i").AutoFit
    
72.       For j = 1 To UBound(lk)
    
73.         .Rows(j).ColumnWidth = lk(j)
    
74.         .Rows(j + 5).ColumnWidth = lk(j)
    
75.       Next
    
76.       With .UsedRange
    
77.         .HorizontalAlignment = xlCenter
    
78.         .VerticalAlignment = xlCenter
    
79.       End With
    
80.     End With
    
81.   Next
    
82. End Sub
    

复制代码

chxw68

详见附件。

ggmmlol

1. Sub 按钮34_Click()
   
2.     Dim sht As Worksheet, arr, i&, x&, y&, p&, tmp()
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     For Each sht In Sheets
   
6.         If sht.Name Like "#*室" Then sht.Delete
   
7.     Next
   
8.     With Sheets("考号").Range("A1").CurrentRegion.Offset(1)
   
9.         .Sort .Cells(1, 5), , .Cells(1, 6), , , Header:=xlYes
   
10.         arr = .Value
    
11.     End With
    
12.     tmp = Sheets("年级桌贴").Range("A1:D3").Value
    
13.     For i = 2 To UBound(arr) - 1
    
14.         If arr(i, 5) <> arr(i - 1, 5) Then
    
15.             If x > 0 Then sht.UsedRange.Offset(x * 4 + 4).Clear
    
16.             Sheets("年级桌贴").Copy After:=Sheets(Sheets.Count)
    
17.             Set sht = ActiveSheet
    
18.             sht.Name = arr(i, 5) & "室"
    
19.             sht.Range("B:B,D:D,G:G,I:I") = ""
    
20.             p = 0
    
21.         Else
    
22.             p = p + 1
    
23.         End If
    
24.         tmp(1, 2) = arr(i, 4)
    
25.         tmp(1, 4) = arr(i, 8)
    
26.         tmp(2, 2) = arr(i, 5)
    
27.         tmp(2, 4) = arr(i, 6)
    
28.         tmp(3, 2) = arr(i, 7)
    
29.         x = p \ 2: y = p Mod 2
    
30.         sht.Cells(x * 4 + 1, y * 5 + 1).Resize(3, 4) = tmp
    
31.     Next
    
32.     If x > 0 Then sht.UsedRange.Offset(x * 4 + 4).Clear
    
33.     Application.DisplayAlerts = True
    
34. End Sub

复制代码

飞起一脚

chxw68 发表于 2018-1-8 20:09
详见附件。

感谢老师的帮助，就是显示分班桌贴的时候，考号好像显示不正确，麻烦老师在写一下。谢谢！

飞起一脚

chxw68 发表于 2018-1-8 20:06

.Cells(m + 1, n + 3) = arr(1, 7)   老师，是不是这个代码有问题？

chxw68

就是有问题！没有认真校对造成的。

chxw68

修改好了。

chxw68

添加了纵横裁切线。