Excel表根据指定数据自动填入固定模板，自动选地方另存、预览和批量打印

yoyolee22

各位大神老师好。

       由于工作需要，复制粘贴量比较庞大，需要将“列表”中的数据填入“模板”中，能否请各位大神老师帮忙设一下代码：
1、根据“列表”中的B列的同类人名数据（收付号可能会不同，存在一条或多条收付号，收付号顺序未必连号），自动填入“模板”中对应的格式中。
2、由于可能收付号会多于两条，“模板”中能否自动增加行填列。
3、“模板”中实发金额=手续费-税费，“模板”中的合计能自动计算。
4、由于列表人数会比较多，能否自动以“模板”中的收款人全称+实发金额命名，提示选择路径另存表格，并提示预览和批量打印。

在此，先谢谢各位老师，希望能得到大神们的帮助，个人会努力学习的，谢谢。

tao60

如果你的目的只是想打印的话，并不需要点击另存那么多文件，可以直接批量打印的。

tao60

如果你的目的只是想打印的话，并不需要点击另存那么多文件，可以直接批量打印的。

yoyolee22

tao60 发表于 2019-7-18 15:53
如果你的目的只是想打印的话，并不需要点击另存那么多文件，可以直接批量打印的。

除了要打印，还是得另存，因为不同的渠道收款人可能有几个，然后不同的渠道会查数，所以还是要另存，所以很麻烦。。。。。。每天都在加班。。。

yoyolee22

tao60 发表于 2019-7-18 15:55
如果你的目的只是想打印的话，并不需要点击另存那么多文件，可以直接批量打印的。

打印是为了给财务支付，另存是为了给渠道查数

tao60

好久没写VBA了，很多代码都不记得了，很多代码都是通过录制宏生成的，然后再进行精简和修改。
功能基本实现了，细节功能，可以自己研究一下。

1. 'tao60  2019-07-18
   
2. 
   
3. Sub AllData()
   
4. '开始批处理
   
5. 
   
6.     Dim iRow As Integer
   
7.     Dim iRowBegin As Integer
   
8.     Dim iRowEnd As Integer
   
9.     Dim iRow_all As Integer
   
10.     Dim strUser As String
    
11.     Dim stemp As String
    
12.     Dim strPath As String
    
13.    
    
14.    
    
15.     Dim shtList As Object
    
16.     Dim shtOut As Object
    
17.     Set shtList = Sheets("列表")
    
18.     Set shtOut = Sheets("模板")
    
19.    
    
20.     '选择保存路径
    
21.     With Application.FileDialog(msoFileDialogFolderPicker)
    
22.         .Title = "选择要保存的路径……"
    
23.         If .Show = False Then
    
24.            Exit Sub
    
25.         End If
    
26.         
    
27.         strPath = .SelectedItems(1)
    
28.     End With
    
29.    
    
30.     '列表最大行号
    
31.     iRow_all = shtList.Range("A65535").End(xlUp).Row
    
32.    
    
33.     iRowBegin = 2
    
34.     strUser = Trim(shtList.Cells(2, 4))
    
35.    
    
36.     '从列表开始行号2开始处理
    
37.     For iRow = 2 To iRow_all Step 1
    
38.         stemp = Trim(shtList.Cells(iRow, 4))
    
39.         
    
40.         If strUser <> stemp Or iRow = iRow_all Then
    
41.             iRowEnd = iRow - 1
    
42.             '处理最后一行2019-07-22
    
43.             If iRow = iRow_all Then
    
44.                 iRowEnd = iRow_all
    
45.             End If
    
46.             '处理同一个收款人的数据，保存到一个文件，请先对列表数据进行排序，按照收款人进行排序
    
47.             Call PathData(iRowBegin, iRowEnd, strUser, strPath)
    
48.             
    
49.             iRowBegin = iRow
    
50.             strUser = shtList.Cells(iRow, 4)
    
51.         End If
    
52.     Next
    
53. 
    
54. End Sub
    
55. 
    
56. Function PathData(iBegin As Integer, iEnd As Integer, sName As String, sPath As String)
    
57. '子程序 根据列表起止行号将列表数据写入到模板中，并另外文件和打印
    
58. 'iBegin 开始行号, iEnd 结束行号, sName 文件名, sPath 另存文件路径
    
59. 
    
60.     If iBegin = 0 Or iEnd = 0 Or iBegin > iEnd Then
    
61.       Exit Function
    
62.     End If
    
63.    
    
64.     Dim shtList As Object
    
65.     Dim shtOut As Object
    
66.     Set shtList = Sheets("列表")
    
67.     Set shtOut = Sheets("模板")
    
68.    
    
69.     shtOut.Rows("4:65535").Delete Shift:=xlUp '删除所有数据行
    
70.    
    
71.     Dim iRowList As Integer
    
72.     Dim iRowOut As Integer
    
73.     Dim iCount As Integer
    
74.    
    
75.     iCount = 1
    
76.     iRowOut = 4 '模板用于填写数据的位置行号
    
77.     For iRowList = iBegin To iEnd Step 1
    
78.         shtOut.Range("A" & iRowOut).Value = iCount
    
79.         shtOut.Range("B" & iRowOut).Value = "'" & shtList.Range("B" & iRowList).Value
    
80.         shtOut.Range("C" & iRowOut).Value = "'" & shtList.Range("C" & iRowList).Value
    
81.         shtOut.Range("D" & iRowOut).Value = shtList.Range("H" & iRowList).Value
    
82.         shtOut.Range("E" & iRowOut).Value = shtList.Range("I" & iRowList).Value
    
83.         shtOut.Range("F" & iRowOut).Value = shtList.Range("J" & iRowList).Value
    
84.         shtOut.Range("G" & iRowOut).FormulaR1C1 = "=RC[-3]-RC[-2]"
    
85.         shtOut.Range("H" & iRowOut).Value = "'" & shtList.Range("D" & iRowList).Value
    
86.         shtOut.Range("I" & iRowOut).Value = "'" & shtList.Range("E" & iRowList).Value
    
87.         shtOut.Range("J" & iRowOut).Value = "'" & shtList.Range("F" & iRowList).Value
    
88.         iCount = iCount + 1
    
89.         iRowOut = iRowOut + 1
    
90.     Next
    
91.    
    
92.     '汇总行
    
93.     shtOut.Range("A" & iRowOut).Value = "合计"
    
94.     shtOut.Range("A" & iRowOut & ":J" & iRowOut).Font.Bold = True
    
95.     shtOut.Range("D" & iRowOut).FormulaR1C1 = "=SUM(R[-" & iCount - 1 & "]C:R[-1]C)"
    
96.     shtOut.Range("E" & iRowOut).FormulaR1C1 = "=SUM(R[-" & iCount - 1 & "]C:R[-1]C)"
    
97.     shtOut.Range("F" & iRowOut).FormulaR1C1 = "=SUM(R[-" & iCount - 1 & "]C:R[-1]C)"
    
98.     shtOut.Range("G" & iRowOut).FormulaR1C1 = "=SUM(R[-" & iCount - 1 & "]C:R[-1]C)"
    
99. 
    
100.     '边框线
     
101.     shtOut.Range("A4:J" & iRowOut).Borders(xlEdgeLeft).LineStyle = xlContinuous
     
102.     shtOut.Range("A4:J" & iRowOut).Borders(xlEdgeTop).LineStyle = xlContinuous
     
103.     shtOut.Range("A4:J" & iRowOut).Borders(xlEdgeBottom).LineStyle = xlContinuous
     
104.     shtOut.Range("A4:J" & iRowOut).Borders(xlEdgeRight).LineStyle = xlContinuous
     
105.     shtOut.Range("A4:J" & iRowOut).Borders(xlInsideVertical).LineStyle = xlContinuous
     
106.     shtOut.Range("A4:J" & iRowOut).Borders(xlInsideHorizontal).LineStyle = xlContinuous
     
107.    
     
108.     '字体
     
109.     shtOut.Range("A4:J" & iRowOut).Font.Name = "宋体"
     
110.     shtOut.Range("A4:J" & iRowOut).Font.Size = 10
     
111.     shtOut.Range("A4:A" & iRowOut).HorizontalAlignment = xlCenter
     
112.    
     
113.     '底部签名栏
     
114.     shtOut.Range("A" & iRowOut + 3).Value = "分公司负责人：                财务负责人：               业管部负责人：              渠道部负责人：                财务复核："
     
115.     shtOut.Range("A" & iRowOut + 6).Value = "代理人：                  制表："
     
116.     shtOut.Range("A" & iRowOut + 9).Value = "总公司分管会计："
     
117.    
     
118.     '另存文件
     
119.     Dim sFileName As String
     
120.     Dim wbOut As Object
     
121.    
     
122.     sFileName = sPath & "" & sName & ".xlsx"
     
123.     shtOut.Copy
     
124.     Set wbOut = ActiveWorkbook
     
125.     wbOut.ActiveSheet.Name = sName
     
126.     wbOut.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, ConflictResolution:=xlLocalSessionChanges
     
127.    
     
128.     '直接打印 无预览
     
129.     wbOut.ActiveSheet.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
     
130.    
     
131.     '关闭
     
132.     wbOut.Close False
     
133. End Function
     
134. 
     
135. Function test()
     
136.     'DEMO测试
     
137.     Call PathData(2, 5, "四四", "D:\2345Downloads")
     
138.    
     
139. End Function
     

复制代码

tao60

晕，刚写的回复，提交回复竟然不见了。

tao60

tao60 发表于 2019-7-18 18:29
晕，刚写的回复，提交回复竟然不见了。

好吧……原来回贴要审核。

zpy2

yoyolee22 发表于 2019-7-18 15:57
除了要打印，还是得另存，因为不同的渠道收款人可能有几个，然后不同的渠道会查数，所以还是要另存，所以 ...

每天都是加班，不会吧。。。工资高吗？

yoyolee22

公司系统落后到爆，提了三年需求，IT还说要排期，前段时间还在问有什么需求。本来系统可以直接输出的数据，还得导几个表再比出来，完了还得做这种费时的事，您觉得这样连系统都不愿投入建设的公司工资会高么。苦逼啊。。。