依据模板批量打印数据为PDF和直接打印

SCWYZJ

求助:上次忘了说，为了跟规范管理，望老师帮助改下代码（详见附件），把符合条件（部门+日期）的数据按照模板打印成以“部门”+“日期”命名的pdf文件数据多的就分多页显示的1个PDF文件或打印。谢谢。

ykcbf1100

附件供参考。。。

ykcbf1100

一个部门一个PDF文件

1. Sub ykcbf2()   '//2024.7.25
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     p = ws.Path & ""
   
7.     Set sh = ws.Sheets("模板")
   
8.     With sh
   
9.         Set Rng = .UsedRange.Find("申请理由")
   
10.         c = Rng.Column: r1 = Rng.Row
    
11.         For j = 2 To c
    
12.             s = Trim(.Cells(r1, j).Value)
    
13.             d1(s) = j
    
14.         Next
    
15.     End With
    
16.     ReDim brr(1 To 1000, 1 To c)
    
17.     With ws.Sheets("数据")
    
18.         Set Rng = .UsedRange.Find("金额")
    
19.         c = Rng.Column: r1 = Rng.Row
    
20.         r = .Cells(Rows.Count, 2).End(3).Row
    
21.         arr = .[a1].Resize(r, c)
    
22.         For i = r1 + 1 To UBound(arr)
    
23.             s = arr(i, 4) & "|" & arr(i, 3)
    
24.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
25.             d(s)(i) = i
    
26.         Next
    
27.     End With
    
28.     rr = 25   '//模板内容行数
    
29.     On Error Resume Next
    
30.     For Each k In d.keys
    
31.         bm = Split(k, "|")(0)
    
32.         rq = Split(k, "|")(1)
    
33.         m = 0: y = 0
    
34.         For Each kk In d(k).keys
    
35.             m = m + 1
    
36.             brr(m, 1) = m
    
37.             For j = 3 To UBound(arr, 2)
    
38.                 s = arr(r1, j)
    
39.                 brr(m, d1(s)) = arr(kk, j)
    
40.             Next
    
41.         Next
    
42.         k = m \ rr + 1    '//分页计数
    
43.         mm = 45
    
44.         sh.Copy
    
45.         Set wb = ActiveWorkbook
    
46.         For x = 1 To k
    
47.             r1 = (x - 1) * rr + 1
    
48.             If x = k Then r2 = m Else r2 = rr * x
    
49.             ReDim zrr(1 To rr, 1 To 9)
    
50.             n = 0
    
51.             For i = r1 To r2
    
52.                 y = y + 1    '//总序号
    
53.                 n = n + 1    '//分表计数
    
54.                 zrr(n, 1) = Format(y, "00")
    
55.                 For j = 2 To UBound(brr, 2)
    
56.                     zrr(n, j) = brr(i, j)
    
57.                 Next
    
58.             Next
    
59.             With wb.Sheets(1)
    
60.                 If x = 1 Then
    
61.                     .[b2] = bm: .[i2] = rq
    
62.                     .[a4].Resize(n, 9) = zrr
    
63.                 Else
    
64.                     sh.Rows("1:37").Copy .Cells(1 + (x - 1) * mm, 1)
    
65.                     .Cells(2 + (x - 1) * mm, 2) = bm: .Cells(2 + (x - 1) * mm, "i") = rq
    
66.                     .Cells(4 + (x - 1) * mm, 1).Resize(n, 9) = zrr
    
67.                 End If
    
68.             End With
    
69.         Next
    
70.         r = mm * k
    
71.         fn = Format(CDate(rq), "yyyymd")
    
72.         wb.Sheets(1).Range("A1:i" & r).ExportAsFixedFormat xlTypePDF, p & bm & "-" & fn & ".pdf"
    
73.         wb.Close 0
    
74.     Next
    
75.     Application.ScreenUpdating = False
    
76.     MsgBox "OK！"
    
77. End Sub
    

复制代码