excel邮件合并

AI56

张道贤 发表于 2019-7-26 18:29

大神，能不能把它改成这种格式？

chxw68

AI56 发表于 2021-11-1 20:22
大神，能不能把它改成这种格式？

不同考场的学生座位卡不能打印在同一页上？

AI56

chxw68 发表于 2021-11-1 21:10
不同考场的学生座位卡不能打印在同一页上？

对，一个考场的学生打印两张纸

AI56

chxw68 发表于 2021-11-1 21:10
不同考场的学生座位卡不能打印在同一页上？

每个考场都要分页

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, hg#(1 To 50), lk#(1 To 9)
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("数据")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a2:g" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     If Not d.exists(arr(i, 5)) Then
    
14.       m = 1
    
15.       ReDim brr(1 To m)
    
16.     Else
    
17.       brr = d(arr(i, 5))
    
18.       m = UBound(brr) + 1
    
19.       ReDim Preserve brr(1 To m)
    
20.     End If
    
21.     brr(m) = i
    
22.     d(arr(i, 5)) = brr
    
23.   Next
    
24.   With Worksheets("结果")
    
25.     .Cells.Clear
    
26.     .Cells.PageBreak = xlPageBreakNone
    
27.   End With
    
28.   r1 = 1
    
29.   With Worksheets("模板")
    
30.     For i = 1 To UBound(hg)
    
31.       hg(i) = .Rows(i).RowHeight
    
32.     Next
    
33.     For j = 1 To UBound(lk)
    
34.       lk(j) = .Columns(j).ColumnWidth
    
35.     Next
    
36.     For Each aa In d.keys
    
37.       brr = d(aa)
    
38.       For i = 1 To UBound(brr) Step 20
    
39.         For x = 1 To 46 Step 5
    
40.           For y = 2 To 7 Step 5
    
41.             .Cells(x, y).Resize(4, 1) = Empty
    
42.             .Cells(x, y + 2).Resize(4, 1) = Empty
    
43.           Next
    
44.         Next
    
45.         m = 1
    
46.         n = 2
    
47.         For k = 1 To 20
    
48.           If i + k - 1 <= UBound(brr) Then
    
49.             .Cells(m, n) = arr(i + k - 1, 4)
    
50.             .Cells(m, n + 2) = arr(i + k - 1, 6)
    
51.             .Cells(m + 1, n) = arr(i + k - 1, 7)
    
52.             .Cells(m + 2, n) = arr(i + k - 1, 5)
    
53.             .Cells(m + 3, n) = arr(i + k - 1, 2)
    
54.             .Cells(m + 3, n + 2) = arr(i + k - 1, 3)
    
55.           End If
    
56.           n = n + 5
    
57.           If n > 7 Then
    
58.             m = m + 5
    
59.             n = 2
    
60.           End If
    
61.         Next
    
62.         .Range("a1:i49").Copy Worksheets("结果").Cells(r1, 1)
    
63.         r1 = r1 + 50
    
64.         With Worksheets("结果")
    
65.           .HPageBreaks.Add before:=.Rows(r1)
    
66.         End With
    
67.       Next
    
68.     Next
    
69.   End With
    
70.   With Worksheets("结果")
    
71.     For i = 1 To r1 - 1 Step 50
    
72.       For k = 1 To 50
    
73.         .Rows(i + k - 1).RowHeight = hg(k)
    
74.       Next
    
75.     Next
    
76.     For j = 1 To UBound(lk)
    
77.       .Columns(j).ColumnWidth = lk(j)
    
78.     Next
    
79.   End With
    
80. End Sub
    

复制代码

chxw68

详见附件。

AI56

chxw68 发表于 2021-11-1 22:05
详见附件。

谢谢，大佬

AI56

chxw68 发表于 2021-11-1 22:05
详见附件。

可以了，没问题

chxw68

前面的代码有问题。

AI56

chxw68 发表于 2021-11-2 11:32
前面的代码有问题。

我就说班级怎么不对，刚好找你呢，谢谢大神，太麻烦你了，不知道怎么鲜花，只会评分