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

tao60

yoyolee22 发表于 2019-7-18 19:56
公司系统落后到爆，提了三年需求，IT还说要排期，前段时间还在问有什么需求。本来系统可以直接输出的数据， ...

有需求不怕，只要肯花钱，网上很多威客网站，有一堆人可以帮你实现功能。我这种散兵，抢不过别人，才到EH这里逛逛。哈哈。

tao60

zpy2 发表于 2019-7-18 19:34
每天都是加班，不会吧。。。工资高吗？

那要看加班算不算加班费，像我们这种加班没有加班费的，我就不用想了。呵呵

yoyolee22

tao60 发表于 2019-7-18 18:27
好久没写VBA了，很多代码都不记得了，很多代码都是通过录制宏生成的，然后再进行精简和修改。
功能基本实 ...

谢谢哥！完全可以实现我的要求，您太好了啊。我早上根据其他大神的贴很认真地学习，但是只能导入同名一条数据，折腾了半天，找我司IT帮忙看一下哪里需要修改，结果IT说不会，本以为帖子太多没人会理我，没想到您帮我处理了，真的太感谢您了，谢谢谢谢谢谢！！！！！

yoyolee22

tao60 发表于 2019-7-18 18:27
好久没写VBA了，很多代码都不记得了，很多代码都是通过录制宏生成的，然后再进行精简和修改。
功能基本实 ...

老师好，请问为什么列表中最后一行的数据无法导入模板里面，也无法另存为一个文件？

tao60

yoyolee22 发表于 2019-7-19 11:36
老师好，请问为什么列表中最后一行的数据无法导入模板里面，也无法另存为一个文件？

哦哦，刚试了下，确实有这个问题，增加一小段代码就可以解决了，我重新上传一份吧。论坛可能不常在线，可以E-Mail，tao60#qq.com (将#换成@)

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 发表于 2019-7-18 18:27
好久没写VBA了，很多代码都不记得了，很多代码都是通过录制宏生成的，然后再进行精简和修改。
功能基本实 ...

感觉很全面

hanson403

tao60 发表于 2019-7-18 18:27
好久没写VBA了，很多代码都不记得了，很多代码都是通过录制宏生成的，然后再进行精简和修改。
功能基本实 ...

老师，如果最后一行数据收款人只有一行数据的话，他会跟上一个收款一起另存为新表。比如：最后一行数据收款人是丙丙，且仅有一行数据，生成时就会跟乙乙在一个表了，这怎么解决呢？第一行数据如果也是仅有一组数据的话，也会把第二组数据代入。就是首尾收款人都不能仅有一组数据

hanson403

哪位大佬能帮忙解决下

hanson403

leeson7502 发表于 2023-11-20 23:44
参与一下：

老师，最后一行还是没有解决，如果最后一行对应的收款人只有一条数据，就会与上一个收款人合并新建工作簿了。 C:\Users\DELL\Desktop\20231120-表格按模板拆分（个人代支表另存）