[已解决]批量打印

guolianjd

求助，用Sheet2表格式，按各个《组名》分别批量打印

表.rar (27.2 KB, 下载次数: 7)

2016-10-1 22:33 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-10-2 20:38

先生成，再打印，再删除。

1. Sub 按村组生成()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 5 To UBound(arr)
   
5.         zu = arr(i, 3)
   
6.         If zu <> "" Then d(zu) = d(zu) & "," & i
   
7.     Next
   
8.    
   
9.     Application.ScreenUpdating = False
   
10.     rmax = 33 '每张表最大人数
    
11.     For Each zu In d.keys
    
12.         xrr = Split(d(zu), ",")
    
13.         rs = UBound(xrr)    '组的人数
    
14.         n = (rs - 0.1) \ rmax + 1
    
15.         For pg = 1 To n
    
16.             Sheets(2).Copy after:=Sheets(Sheets.Count)
    
17.             With ActiveSheet
    
18.                 .Name = zu & pg
    
19.                 ReDim brr(1 To rmax, 1 To UBound(arr, 2))
    
20.                 s = (pg - 1) * 33  '起始位置
    
21.                 For r = 1 To rmax
    
22.                     If r + s <= rs Then
    
23.                         i = xrr(r + s)
    
24.                         For j = 1 To UBound(arr, 2)
    
25.                             brr(r, j) = arr(i, j)
    
26.                         Next
    
27.                     End If
    
28.                 Next
    
29.                 .[a5].Resize(rmax, UBound(brr, 2)) = brr
    
30.             End With
    
31.         Next
    
32.     Next
    
33.     Sheets(1).Activate
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    
36. 
    
37. Sub 清除()
    
38.     Application.ScreenUpdating = False
    
39.     Application.DisplayAlerts = False
    
40.     For Each sh In Worksheets
    
41.         If sh.Index > 2 Then sh.Delete
    
42.     Next
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    
46. 
    
47. Sub 打印()
    
48.     For Each sh In Worksheets
    
49.         If sh.Index > 2 Then sh.PrintPreview
    
50.         'If sh.Index > 2 Then sh.PrintOut
    
51.     Next
    
52. End Sub
    

复制代码

跳转到最佳答案楼层

砂海

看不出 有学习的迹象 ,
直接找人 有偿服务 就可以.
有的论坛 有这样的板块 ,
X宝 什么的 上面也有. (搜索 "excel "或者 加上 "Vba" )  

grf1973

先生成，再打印，再删除。

1. Sub 按村组生成()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 5 To UBound(arr)
   
5.         zu = arr(i, 3)
   
6.         If zu <> "" Then d(zu) = d(zu) & "," & i
   
7.     Next
   
8.    
   
9.     Application.ScreenUpdating = False
   
10.     rmax = 33 '每张表最大人数
    
11.     For Each zu In d.keys
    
12.         xrr = Split(d(zu), ",")
    
13.         rs = UBound(xrr)    '组的人数
    
14.         n = (rs - 0.1) \ rmax + 1
    
15.         For pg = 1 To n
    
16.             Sheets(2).Copy after:=Sheets(Sheets.Count)
    
17.             With ActiveSheet
    
18.                 .Name = zu & pg
    
19.                 ReDim brr(1 To rmax, 1 To UBound(arr, 2))
    
20.                 s = (pg - 1) * 33  '起始位置
    
21.                 For r = 1 To rmax
    
22.                     If r + s <= rs Then
    
23.                         i = xrr(r + s)
    
24.                         For j = 1 To UBound(arr, 2)
    
25.                             brr(r, j) = arr(i, j)
    
26.                         Next
    
27.                     End If
    
28.                 Next
    
29.                 .[a5].Resize(rmax, UBound(brr, 2)) = brr
    
30.             End With
    
31.         Next
    
32.     Next
    
33.     Sheets(1).Activate
    
34.     Application.ScreenUpdating = True
    
35. End Sub
    
36. 
    
37. Sub 清除()
    
38.     Application.ScreenUpdating = False
    
39.     Application.DisplayAlerts = False
    
40.     For Each sh In Worksheets
    
41.         If sh.Index > 2 Then sh.Delete
    
42.     Next
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    
46. 
    
47. Sub 打印()
    
48.     For Each sh In Worksheets
    
49.         If sh.Index > 2 Then sh.PrintPreview
    
50.         'If sh.Index > 2 Then sh.PrintOut
    
51.     Next
    
52. End Sub
    

复制代码

grf1973

调试中打印用了预览模式（代码第49行），实际使用中可注释掉第49行，用第50行。

guolianjd

grf1973 发表于 2016-10-2 20:38
先生成，再打印，再删除。

谢谢，真是学无止境，我只会搬运，学不会代码[em03]