如何根据编排依据和模板生成单年级或全部标签20170623

yzyyyyyyy

编排依据：分年级列出试场号，考室，人数。 如何根据编排依据和模板生成单年级或全部标签20170623.rar (7.78 KB, 下载次数: 6)

2017-6-23 18:22 上传

点击文件名下载附件

因各年级期末不是同时考试，所以同一试场号但考室不一定是同一地点，现在需要在考务室贴标签，为节省纸质，只贴一次标签，各年级考试通用。
标签模板：制作了8张
标签成品：根据编排依据中的M1的值，生成各年级的标签，若为全部，则同时生成各年级标签。其中关键字为试场号。
有两个样本：单年级，全部。最终是生成到标签成品中。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("编排依据")
   
7.     For j = 1 To 9 Step 4
   
8.       r = .Cells(.Rows.Count, j).End(xlUp).Row
   
9.       arr = .Cells(1, j).Resize(r, 3)
   
10.       For i = 2 To UBound(arr)
    
11.         If Not d.exists(arr(i, 1)) Then
    
12.           m = 1
    
13.           ReDim brr(1 To 3, 1 To m)
    
14.         Else
    
15.           brr = d(arr(i, 1))
    
16.           m = UBound(brr, 2) + 1
    
17.           ReDim Preserve brr(1 To 3, 1 To m)
    
18.         End If
    
19.         brr(1, m) = arr(1, 3)
    
20.         brr(2, m) = arr(i, 3)
    
21.         brr(3, m) = arr(i, 2)
    
22.         d(arr(i, 1)) = brr
    
23.       Next
    
24.     Next
    
25.   End With
    
26.   With Worksheets("标签成品全部样本")
    
27.     .Range("a6:i" & .Rows.Count).Clear
    
28.     n = 1
    
29.     q = 1
    
30.     .Range("a3:c5,g3:i5").ClearContents
    
31.     For Each aa In d.keys
    
32.       brr = d(aa)
    
33.       ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
34.       For i = 1 To UBound(brr)
    
35.         For j = 1 To UBound(brr, 2)
    
36.           crr(j, i) = brr(i, j)
    
37.         Next
    
38.       Next
    
39.       .Cells(1, n) = "第" & aa & "考场"
    
40.       With .Cells(1, n)
    
41.         .Value = "第" & aa & "考场"
    
42.         With .Characters(Start:=2, Length:=Len(aa)).Font
    
43.           .Name = "Times New Roman"
    
44.           .Size = 60
    
45.         End With
    
46.       End With
    
47.       .Cells(3, n).Resize(UBound(crr), UBound(crr, 2)) = crr
    
48.       n = n + 6
    
49.       If n > 7 Then
    
50.         q = q + 7
    
51.         .Range("a1:i5").Copy .Cells(q, 1)
    
52.         .Range("a3:c5,g3:i5").ClearContents
    
53.         n = 1
    
54.       End If
    
55.     Next
    
56.     If d.Count Mod 2 <> 0 Then
    
57.       q = q + 7
    
58.       .Range("a1:i5").Copy Cells(q, 1)
    
59.     End If
    
60.     .Range("a1:i7").Delete shift:=xlUp
    
61.   End With
    
62. End Sub
    

复制代码

chxw68

写了生成全部标签的代码，生成单个年级的标签代码很简单，楼主可借鉴修改完成。

yzyyyyyyy

chxw68 发表于 2017-6-23 19:13
写了生成全部标签的代码，生成单个年级的标签代码很简单，楼主可借鉴修改完成。

感谢大师热心帮助，大师的代码匠心独运，回味无穷。单年级标签和全部年级标签，能否与年级，即7年级，8年级，9年级，全部，即单元格m1值关联，即选择值后运行程序，即在标签成品表中生成相应的标签。大师辛苦了。

chxw68

修改好了。