excel邮件合并

AI56

学生的作为卡怎么做呀?去大神帮忙！！有的考场25个学生，有的考场25以下

张道贤

AI56 发表于 2019-7-24 12:34
对，有空白页，第二页都是空白的，我不会改，现在太晚了，明天能不能帮我改一下呀大神

1. Sub 座位表()
   
2. Application.ScreenUpdating = False
   
3.   Set ang = Sheet1.[a1].CurrentRegion
   
4.   Set d = CreateObject("scripting.dictionary"): d(ang(2, 5).Value) = 1: bj = 2
   
5.   With Sheet2: .Range("A1:Y1000").ClearContents: m = 1: .Rows("1:40").RowHeight = 18.25
   
6.     For i = 2 To ang.End(xlDown).Row
   
7.       A = (m + bj - 1) Mod bj: n = 5 * ((m + bj - 1 - A) / bj - 1) + 1: j = A * 5 + 1
   
8.       .Cells(n, j).Offset(0, 0) = "姓名":     .Cells(n, j).Offset(0, 1) = ang(i, 4).Value
   
9.       .Cells(n, j).Offset(1, 0) = "年级":     .Cells(n, j).Offset(1, 1) = ang(i, 2).Value
   
10.       .Cells(n, j).Offset(1, 2) = "班级":     .Cells(n, j).Offset(1, 3) = ang(i, 3).Value
    
11.       .Cells(n, j).Offset(2, 0) = "考场号":   .Cells(n, j).Offset(2, 1) = ang(i, 5).Value
    
12.       .Cells(n, j).Offset(2, 2) = "座位号":   .Cells(n, j).Offset(2, 3) = ang(i, 6).Value
    
13.       .Cells(n, j).Offset(3, 0) = "考生号":   .Cells(n, j).Offset(3, 1) = "'" & ang(i, 7).Value
    
14.       m = m + 1
    
15.       If ang(i + 1, 5).Value <> Application.Index(d.KEYS, d.Count) Then
    
16.          maxro = .Cells(Rows.Count, "a").End(xlUp).Row + 1
    
17.          If maxro > 40 Then
    
18.             .Rows("1:5").Copy
    
19.             .Rows("41:" & maxro).PasteSpecial Paste:=xlPasteFormats, _
    
20.                 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
21.          End If
    
22.          .PrintOut Copies:=1: d(ang(i + 1, 5).Value) = 1
    
23.         If maxro > 40 Then .Rows("41:" & maxro).Delete Shift:=xlUp
    
24.         .Range("A1:Y1000").ClearContents: m = 1
    
25.       End If
    
26.     Next i: End With: ang = ""
    
27. Application.ScreenUpdating = True
    
28. End Sub

复制代码

张道贤

也就是循环的运用和字典的判断

AI56

张道贤 发表于 2019-4-21 20:04
也就是循环的运用和字典的判断

用你的带单转学了简单的vba，写了好几次都不对，能不能直接写个代码呀

张道贤

AI56 发表于 2019-7-23 22:03
用你的带单转学了简单的vba，写了好几次都不对，能不能直接写个代码呀

看附件吧，代码是执行打印，有漏洞（会出现打印空表）

你自己看着修改吧

excel邮件合并测试1.zip (147.98 KB, 下载次数: 26)

2019-7-23 22:32 上传

点击文件名下载附件

AI56

对，有空白页，第二页都是空白的，我不会改，现在太晚了，明天能不能帮我改一下呀大神

liulang0808

这个需求论坛里应该有雷同的，楼主可以搜下看看的

AI56

张道贤 发表于 2019-7-23 22:34
看附件吧，代码是执行打印，有漏洞（会出现打印空表）

你自己看着修改吧

对，有空白页，第二页都是空白的，我不会改，现在太晚了，明天能不能帮我改一下呀大神

AI56

liulang0808 发表于 2019-7-24 07:53
这个需求论坛里应该有雷同的，楼主可以搜下看看的

没有一样的呀

AI56

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

好了，谢谢