通过凭证明细，自动生成明细账及科目余额表

楼主 kevinchengcw	一个通过凭证记录可以自动生成明细账和科目余额表的工作簿，对明细账支持个别生成及批量生成：个别生成代码如下： Sub 个别生成() Dim M, N, I, T As Integer N = 5 With ActiveSheet If .Name = "个别生成页" And .Range("d2") = "" Then '判断编码是否已输入 '如果为空，则选中该单元格，并显示提示对话框，然后退出处理 .Range("d2").Select MsgBox "请先输入编码", vbOKOnly, "错误" Exit Sub End If .Rows("5:65536").Delete '清空数据区以便写入新数据 End With Application.ScreenUpdating = False '关闭屏幕刷新以提高速度 With Worksheets("凭证明细表") '以下为写入过程 ActiveSheet.Cells(N, 5) = "期初金额" 'E列的当前行的文本为“期初金额” ActiveSheet.Cells(N, 9) = WorksheetFunction.VLookup(ActiveSheet.Cells(2, 4).Value, Worksheets("期初余额").UsedRange, 3, 0) '在期初余额表中查询对应的数值并写入I列当前行 N = N + 1 '下移一行 T = 2 '预设凭证明细表操作起始行，主要用于判断年份是否跨越 For M = 2 To .Cells(Rows.Count, 1).End(3).Row '循环提取凭证明细表的数据区各行数据 If .Cells(M, 1).Value = ActiveSheet.Cells(2, 4).Value Then '如果单元格的值与生成的明细账表的当前科目编码一致，则执行下述操作 If ActiveSheet.Cells(3, 2) <> "" Then '判断是否预设了要提取的年份，如果是（即明细账表中的"B3"单元格的值不为空），则执行下述操作 If .Cells(M, 5).Value = ActiveSheet.Cells(3, 2).Value Then '如果凭证明细表中当前循环的行的E列的值与预设年份一致，则执行下述操作 For I = 2 To 7 '循环赋值凭证明细表中当前行的B列到G列的值到生成的明细表中当前行 ActiveSheet.Cells(N, I) = .Cells(M, I + 4) Next I With ActiveSheet ’在明细账表中再进行下述计算（计算余额） If .Cells(N - 1, 9) = "" Then '如果上一行的I列为空，则 .Cells(N, 9) = .Cells(N - 2, 9) + .Cells(N, 6) - .Cells(N, 7) '当前行的I列的值等于I列当前行的上两行的值加上本行F列的值减去G列的值（此情况仅在跨年份的时候会出现，因为到时会插入一个跨年标志行） Else '如果上一行的I列不为空，则 .Cells(N, 9) = .Cells(N - 1, 9) + .Cells(N, 6) - .Cells(N, 7) '当前行的I列的值等于I列当前行的上一行的值加上本行F列的值减去G列的值 End If End With N = N + 1 '下移一行 End If Else '如果未预设要提取的年份，则执行提取全部该科目名称的数据的操作 If .Cells(T, 5) <> .Cells(M, 5) And .Cells(T, 5) <> "" Then '如果当前行的年份与初始年份不同，则 ActiveSheet.Range(ActiveSheet.Cells(N, 2), ActiveSheet.Cells(N, 9)).Interior.Color = vbRed '在生成的明细账表中插入一个跨年标志行，设置成红色底色 ActiveSheet.Cells(N, 5) = .Cells(M, 5).Value & "期初金额" '标志行文字设为凭证明细表当前行的年份值 N = N + 1 '插入完标志行后下移一行 End If For I = 2 To 7 '向明细账表写入凭证明细表B列到G列的内容 ActiveSheet.Cells(N, I) = .Cells(M, I + 4) Next I With ActiveSheet '计算余额，方法同上 If .Cells(N - 1, 9) = "" Then .Cells(N, 9) = .Cells(N - 2, 9) + .Cells(N, 6) - .Cells(N, 7) Else .Cells(N, 9) = .Cells(N - 1, 9) + .Cells(N, 6) - .Cells(N, 7) End If End With N = N + 1 '下移一行 T = M '将新的年份据在行的值赋值给T End If End If Next M End With With ActiveSheet '以下为插入年和月份汇总的代码，N值为从上一代码段延续过来的 M = .Cells(Rows.Count, 2).End(3).Row '判断B列数据行的最末行数 Do While N >= 6 Or N = M '当N值处于数据区内时执行循环操作 If M = N Or (Cells(N, 2) <> Cells(N + 1, 2) And Cells(N, 2).Interior.Color <> vbRed) Then '当处于最末行时或与B列下一行数据不一致时（即月份不同时）或单元格颜色为红色时（即处于跨年标志行上时）执行下述操作 .Rows(N + 1 & ":" & N + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '向当前行下部插入两行，并复制上方或左侧单元格格式 .Range(.Cells(N + 1, 2), .Cells(N + 2, 9)).Interior.Color = vbYellow '将插入的两行单元格的底色设置为黄色 I = WorksheetFunction.CountIf(.Range(.Cells(N, 2), .Cells(6, 2)), .Cells(N, 2)) '判断当前单元格至数据顶部B列相同日期的行数并赋值给变量I .Cells(N + 1, 5) = "本月累计" '插入行的上面行E列文本为“本月累计” .Cells(N + 1, 6) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(N - I + 1, 6))) '将判断得到的行数数值加和 .Cells(N + 1, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 7), .Cells(N - I + 1, 7))) .Cells(N + 1, 9) = .Cells(N, 9) .Cells(N + 2, 5) = "本年累计" '插入行的下面行E列文本为“本年累计” .Cells(N + 2, 6) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(6, 6))) '将判断得到的行数数值加和 .Cells(N + 2, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 7), .Cells(6, 7))) .Cells(N + 2, 9) = .Cells(N, 9) End If N = N - 1 '上移一行 Loop End With Application.ScreenUpdating = True End Sub 批量写入代码如下： Sub 批量生成() Dim Ws As Worksheet Worksheets("模板").Visible = xlSheetVisible '取消模板的隐藏 Application.DisplayAlerts = False '因为要删除旧有的表所以要关闭提示 For Each Ws In ThisWorkbook.Worksheets '枚举工作表，删除以前生成的工作表 If Ws.Name <> "凭证明细表" And Ws.Name <> "批量操作页" And Ws.Name <> "期初余额" And Ws.Name <> "模板" And Ws.Name <> "个别生成页" Then Ws.Delete Next Ws Application.DisplayAlerts = True With Worksheets("期初余额") '以下是批量生成过程，调用个别生成的代码完成 For N = 1 To .Cells(Rows.Count, 1).End(3).Row '循环期初余额表中的数据行，生成对应科目的明细账表 Worksheets("个别生成页").Copy before:=Worksheets(1) '复制个别生成页到工作表标签的最前面 Worksheets(1).[d2] = Worksheets("期初余额").Cells(N, 1).Value '写入科目编码 Worksheets(1).Name = Worksheets("期初余额").Cells(N, 1).Value '以科目编码命名该工作表 Worksheets(1).Activate 个别生成 '调用个别生成的代码 Next N End With Worksheets("模板").Visible = xlSheetVeryHidden '完成后将模板隐藏 End Sub 生成的明细帐样式生成科目余额表代码如下： Public mDate As Date '定义用于传递输入日期的公共变量 Sub 生成科目余额表() Dim Ws As Worksheet msg = MsgBox("该操作将删除旧的科目余额表，确认操作？" & vbnew & "是：继续执行" & vbNewLine & "否：退出操作", vbYesNo, "提示") '询问是否确认删除已有科目表 If msg = vbNo Then Exit Sub Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets If Ws.Name = "科目余额表" Then '查找旧的科目余额表并删除 Application.DisplayAlerts = False Ws.Delete Application.DisplayAlerts = True End If Next Ws Application.ScreenUpdating = True UserForm1.Show '显示日期输入窗体 End Sub Sub 科目余额表() '正式生成科目余额表的代码 Dim Ws, Form As Worksheet Dim M, N, I As Integer Dim Begin, mTotal1, mTotal2, yTotal1, yTotal2, Total1, Total2 As Double 'MsgBox mDate Application.ScreenUpdating = False Worksheets("科目余额表模板").Visible = xlSheetVisible '将模板取消隐藏并复制，如果改为用代码生成表头的话可以不用模板 Worksheets("科目余额表模板").Copy before:=Worksheets(1) Set Form = Worksheets(1) Form.Name = "科目余额表" Form.Move before:=Worksheets(1) With Form .[c1] = Year(mDate) '输入选定的日期 .[d1] = Month(mDate) .[e1] = Day(mDate) N = 3 For M = 1 To Worksheets("期初余额").Cells(Rows.Count, 1).End(3).Row '初始化各项目开始累积值 mTotal1 = 0 '本月借方累计 mTotal2 = 0 '本月贷方累计 yTotal1 = 0 '本年借方累计 yTotal2 = 0 '本年贷方累计 Total1 = 0 '借方总累计 Total2 = 0 '贷方总累计 .Cells(N, 1) = Worksheets("期初余额").Cells(M, 1) '写入科目代码、名称及截止日期 .Cells(N, 2) = Worksheets("期初余额").Cells(M, 2) .Cells(N, 3) = .[c1] .Cells(N, 4) = .[d1] .Cells(N, 5) = .[e1] Begin = Worksheets("期初余额").Cells(M, 3) '设定期初金额 For I = 2 To Worksheets("凭证明细表").Cells(Rows.Count, 1).End(3).Row '循环累计各项 If Worksheets("凭证明细表").Cells(I, 1) = .Cells(N, 1) Then '判断凭证明细表当前单元格内容是否与科目余额表当前单元格内容一致 If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) < DateValue(Year(mDate) & "-" & Month(mDate) & "-1") Then '判断是否当前日期为输入日期的上个月（含）之前的内容 Begin = Begin + Worksheets("凭证明细表").Cells(I, 10).Value - Worksheets("凭证明细表").Cells(I, 11).Value End If If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) <= mDate Then '判断当前日期是否是输入日期之前的内容 Total1 = Total1 + Worksheets("凭证明细表").Cells(I, 10) Total2 = Total2 + Worksheets("凭证明细表").Cells(I, 11) End If If Worksheets("凭证明细表").Cells(I, 5).Value = Year(mDate) Then '判断当前日期是否是输入日期当年的内容 If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) <= mDate Then '继续判断是否是输入日期之前的内容 yTotal1 = yTotal1 + Worksheets("凭证明细表").Cells(I, 10).Value yTotal2 = yTotal2 + Worksheets("凭证明细表").Cells(I, 11).Value End If If Worksheets("凭证明细表").Cells(I, 6).Value = Month(mDate) And Worksheets("凭证明细表").Cells(I, 7).Value <= Day(mDate) Then '继续判断是否是输入日期当月并且是当日之前的内容 mTotal1 = mTotal1 + Worksheets("凭证明细表").Cells(I, 10).Value mTotal2 = mTotal2 + Worksheets("凭证明细表").Cells(I, 11).Value End If End If End If Next I .Cells(N, 6) = Begin '写入累计结果 .Cells(N, 7) = mTotal1 .Cells(N, 8) = mTotal2 .Cells(N, 9) = yTotal1 .Cells(N, 10) = yTotal2 .Cells(N, 11) = Total1 .Cells(N, 12) = Total2 .Cells(N, 13) = Worksheets("期初余额").Cells(M, 3) + Total1 - Total2 N = N + 1 Next M .Columns("F:M").NumberFormatLocal = "0.00" '设置对应区域数值格式 .Range(Cells(2, 1), Cells(N - 1, 13)).Borders.LineStyle = 1 '数据区域加上网格线 End With Worksheets("科目余额表模板").Visible = xlSheetVeryHidden '隐藏模板 Application.ScreenUpdating = True End Sub 生成效果如下图：详见附件。通过凭证明细，自动生成明细账及科目余额表.rar
2楼梧桐小雨	很有意思。谢谢
3楼惜红衣	为什么我下载后打开，显示的是：编译错误：找不到工程或库菜鸟级别，请高手解释一下：）
4楼 xing768	谢谢了！为什么点击批量生成显示错误啊？批量生成和个别生成是什么意思？不好意思问这么简单的问题。
5楼 yardview	好东东大家分享，谢谢提供
6楼信合人	好东东大家分享，谢谢提供
7楼信合人	为啥链接不能用哦
8楼 jlsbg	是否根据记账凭证直接输入凭证明细表就可以了？历年借方累计历年贷方累计是怎样来的？有需要结转的怎样实现
9楼庭院幽幽	哦，好好学习，这些代码要研究一阵了
10楼 kekedoufeng513	学习！
11楼 shujiandi	不错挺实用的
12楼 sykt888	为什么不好用呀
13楼信合人	为啥链接不能用哦
14楼熊宝宝的爱情	学习学习。。
15楼 pk_07	多少楼了？
16楼江河源	刚接触，看看。
17楼 jimmy1022	好东东大家分享，谢谢楼主无私奉献
18楼 lgcmeli	谢谢楼主分析。谢谢et社区。
19楼 aob	好东东大家分享，谢谢提供
20楼 thjwh	编程啊。
21楼 wang123hua	学习一下,感觉难啊
22楼远古石器
23楼 liuguansky	完整系统开发思路，学习了。以后自己也写一个。
24楼 wjgzs	学习下！
25楼 qinhuan66	走过路过千万别错过
26楼康冰悦	学习学习！
27楼 stella_tan	不会用
28楼 renrg68	谢谢分享！好好学习一下。
29楼 renrg68	能不能给我发个该作品的模板，十分感谢！我的邮箱是：
30楼 yll110	下来学习了,谢谢
31楼于晓庆
32楼 fgaq111	晕了，离我比较遥远了
33楼 zawseed	压缩包中有解释吗？
34楼罗小雪	很有意思。谢谢
35楼 zjylsjwz	看见代码就晕菜，路过~~
36楼 sonnygreen	谢谢分享……
37楼 magi	真是非常实用
38楼 soho	很有意思。谢谢
39楼 yiyirang	先下载下来看看，有问题再请教！谢谢啦！
40楼 zhaoqq2011	原来都是高手啊**！佩服佩服
41楼 lshqbj	我想收藏这个帖子,不知道怎么操作?
42楼落凡78535410	谢谢楼主的无私奉献真的谢谢楼主好人永远好运
43楼 dxwzm	表格不规范！也无法打印出合格的账本来**
44楼 lrlxxqxa	表格不规范，任何方法都无从下手的。
45楼张啸宁	这个挺有意思的，就是全是vba 啊，不好懂！
46楼 dxwzm	只要稍改进一下是可以的！
47楼 rqmiy	呵呵，帖子不错，支持一下 5psj.com 破碎机反击式破碎机
48楼于晓庆
49楼 renrg68
50楼 heqazas	学习！
51楼 lrlxxqxa	强大
52楼 19980919hy	能否说明应用价值，达到的这个效果应该说从财务软件中就可以轻易实现
53楼税海	好东东大家分享，谢谢提供
54楼 TokiGi	基于财务系统的话，肯定不需要了。但是如果有台账的情况就很有必要哦。由于财务系统没有出纳模块，我现在正在找出纳台账的登记然后自动按银行出明细账的功能。
55楼璞玉可待	楼长，组件文件没上传全。
56楼 hungg	就看看，不说话。
57楼悠悠雨	太好了
58楼桃源乡	楼主，你好，我修改了下表，但余额方向不对，请帮忙完善下。谢谢总账及明细账.zip
59楼 272779357	好好学习
60楼 plsbee	楼主谢谢！好东西，收藏了
61楼 kevinchengcw	一个通过凭证记录可以自动生成明细账和科目余额表的工作簿，对明细账支持个别生成及批量生成：个别生成代码如下： Sub 个别生成() Dim M, N, I, T As Integer N = 5 With ActiveSheet If .Name = "个别生成页" And .Range("d2") = "" Then '判断编码是否已输入 '如果为空，则选中该单元格，并显示提示对话框，然后退出处理 .Range("d2").Select MsgBox "请先输入编码", vbOKOnly, "错误" Exit Sub End If .Rows("5:65536").Delete '清空数据区以便写入新数据 End With Application.ScreenUpdating = False '关闭屏幕刷新以提高速度 With Worksheets("凭证明细表") '以下为写入过程 ActiveSheet.Cells(N, 5) = "期初金额" 'E列的当前行的文本为“期初金额” ActiveSheet.Cells(N, 9) = WorksheetFunction.VLookup(ActiveSheet.Cells(2, 4).Value, Worksheets("期初余额").UsedRange, 3, 0) '在期初余额表中查询对应的数值并写入I列当前行 N = N + 1 '下移一行 T = 2 '预设凭证明细表操作起始行，主要用于判断年份是否跨越 For M = 2 To .Cells(Rows.Count, 1).End(3).Row '循环提取凭证明细表的数据区各行数据 If .Cells(M, 1).Value = ActiveSheet.Cells(2, 4).Value Then '如果单元格的值与生成的明细账表的当前科目编码一致，则执行下述操作 If ActiveSheet.Cells(3, 2) <> "" Then '判断是否预设了要提取的年份，如果是（即明细账表中的"B3"单元格的值不为空），则执行下述操作 If .Cells(M, 5).Value = ActiveSheet.Cells(3, 2).Value Then '如果凭证明细表中当前循环的行的E列的值与预设年份一致，则执行下述操作 For I = 2 To 7 '循环赋值凭证明细表中当前行的B列到G列的值到生成的明细表中当前行 ActiveSheet.Cells(N, I) = .Cells(M, I + 4) Next I With ActiveSheet ’在明细账表中再进行下述计算（计算余额） If .Cells(N - 1, 9) = "" Then '如果上一行的I列为空，则 .Cells(N, 9) = .Cells(N - 2, 9) + .Cells(N, 6) - .Cells(N, 7) '当前行的I列的值等于I列当前行的上两行的值加上本行F列的值减去G列的值（此情况仅在跨年份的时候会出现，因为到时会插入一个跨年标志行） Else '如果上一行的I列不为空，则 .Cells(N, 9) = .Cells(N - 1, 9) + .Cells(N, 6) - .Cells(N, 7) '当前行的I列的值等于I列当前行的上一行的值加上本行F列的值减去G列的值 End If End With N = N + 1 '下移一行 End If Else '如果未预设要提取的年份，则执行提取全部该科目名称的数据的操作 If .Cells(T, 5) <> .Cells(M, 5) And .Cells(T, 5) <> "" Then '如果当前行的年份与初始年份不同，则 ActiveSheet.Range(ActiveSheet.Cells(N, 2), ActiveSheet.Cells(N, 9)).Interior.Color = vbRed '在生成的明细账表中插入一个跨年标志行，设置成红色底色 ActiveSheet.Cells(N, 5) = .Cells(M, 5).Value & "期初金额" '标志行文字设为凭证明细表当前行的年份值 N = N + 1 '插入完标志行后下移一行 End If For I = 2 To 7 '向明细账表写入凭证明细表B列到G列的内容 ActiveSheet.Cells(N, I) = .Cells(M, I + 4) Next I With ActiveSheet '计算余额，方法同上 If .Cells(N - 1, 9) = "" Then .Cells(N, 9) = .Cells(N - 2, 9) + .Cells(N, 6) - .Cells(N, 7) Else .Cells(N, 9) = .Cells(N - 1, 9) + .Cells(N, 6) - .Cells(N, 7) End If End With N = N + 1 '下移一行 T = M '将新的年份据在行的值赋值给T End If End If Next M End With With ActiveSheet '以下为插入年和月份汇总的代码，N值为从上一代码段延续过来的 M = .Cells(Rows.Count, 2).End(3).Row '判断B列数据行的最末行数 Do While N >= 6 Or N = M '当N值处于数据区内时执行循环操作 If M = N Or (Cells(N, 2) <> Cells(N + 1, 2) And Cells(N, 2).Interior.Color <> vbRed) Then '当处于最末行时或与B列下一行数据不一致时（即月份不同时）或单元格颜色为红色时（即处于跨年标志行上时）执行下述操作 .Rows(N + 1 & ":" & N + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '向当前行下部插入两行，并复制上方或左侧单元格格式 .Range(.Cells(N + 1, 2), .Cells(N + 2, 9)).Interior.Color = vbYellow '将插入的两行单元格的底色设置为黄色 I = WorksheetFunction.CountIf(.Range(.Cells(N, 2), .Cells(6, 2)), .Cells(N, 2)) '判断当前单元格至数据顶部B列相同日期的行数并赋值给变量I .Cells(N + 1, 5) = "本月累计" '插入行的上面行E列文本为“本月累计” .Cells(N + 1, 6) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(N - I + 1, 6))) '将判断得到的行数数值加和 .Cells(N + 1, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 7), .Cells(N - I + 1, 7))) .Cells(N + 1, 9) = .Cells(N, 9) .Cells(N + 2, 5) = "本年累计" '插入行的下面行E列文本为“本年累计” .Cells(N + 2, 6) = WorksheetFunction.Sum(.Range(.Cells(N, 6), .Cells(6, 6))) '将判断得到的行数数值加和 .Cells(N + 2, 7) = WorksheetFunction.Sum(.Range(.Cells(N, 7), .Cells(6, 7))) .Cells(N + 2, 9) = .Cells(N, 9) End If N = N - 1 '上移一行 Loop End With Application.ScreenUpdating = True End Sub 批量写入代码如下： Sub 批量生成() Dim Ws As Worksheet Worksheets("模板").Visible = xlSheetVisible '取消模板的隐藏 Application.DisplayAlerts = False '因为要删除旧有的表所以要关闭提示 For Each Ws In ThisWorkbook.Worksheets '枚举工作表，删除以前生成的工作表 If Ws.Name <> "凭证明细表" And Ws.Name <> "批量操作页" And Ws.Name <> "期初余额" And Ws.Name <> "模板" And Ws.Name <> "个别生成页" Then Ws.Delete Next Ws Application.DisplayAlerts = True With Worksheets("期初余额") '以下是批量生成过程，调用个别生成的代码完成 For N = 1 To .Cells(Rows.Count, 1).End(3).Row '循环期初余额表中的数据行，生成对应科目的明细账表 Worksheets("个别生成页").Copy before:=Worksheets(1) '复制个别生成页到工作表标签的最前面 Worksheets(1).[d2] = Worksheets("期初余额").Cells(N, 1).Value '写入科目编码 Worksheets(1).Name = Worksheets("期初余额").Cells(N, 1).Value '以科目编码命名该工作表 Worksheets(1).Activate 个别生成 '调用个别生成的代码 Next N End With Worksheets("模板").Visible = xlSheetVeryHidden '完成后将模板隐藏 End Sub 生成的明细帐样式生成科目余额表代码如下： Public mDate As Date '定义用于传递输入日期的公共变量 Sub 生成科目余额表() Dim Ws As Worksheet msg = MsgBox("该操作将删除旧的科目余额表，确认操作？" & vbnew & "是：继续执行" & vbNewLine & "否：退出操作", vbYesNo, "提示") '询问是否确认删除已有科目表 If msg = vbNo Then Exit Sub Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets If Ws.Name = "科目余额表" Then '查找旧的科目余额表并删除 Application.DisplayAlerts = False Ws.Delete Application.DisplayAlerts = True End If Next Ws Application.ScreenUpdating = True UserForm1.Show '显示日期输入窗体 End Sub Sub 科目余额表() '正式生成科目余额表的代码 Dim Ws, Form As Worksheet Dim M, N, I As Integer Dim Begin, mTotal1, mTotal2, yTotal1, yTotal2, Total1, Total2 As Double 'MsgBox mDate Application.ScreenUpdating = False Worksheets("科目余额表模板").Visible = xlSheetVisible '将模板取消隐藏并复制，如果改为用代码生成表头的话可以不用模板 Worksheets("科目余额表模板").Copy before:=Worksheets(1) Set Form = Worksheets(1) Form.Name = "科目余额表" Form.Move before:=Worksheets(1) With Form .[c1] = Year(mDate) '输入选定的日期 .[d1] = Month(mDate) .[e1] = Day(mDate) N = 3 For M = 1 To Worksheets("期初余额").Cells(Rows.Count, 1).End(3).Row '初始化各项目开始累积值 mTotal1 = 0 '本月借方累计 mTotal2 = 0 '本月贷方累计 yTotal1 = 0 '本年借方累计 yTotal2 = 0 '本年贷方累计 Total1 = 0 '借方总累计 Total2 = 0 '贷方总累计 .Cells(N, 1) = Worksheets("期初余额").Cells(M, 1) '写入科目代码、名称及截止日期 .Cells(N, 2) = Worksheets("期初余额").Cells(M, 2) .Cells(N, 3) = .[c1] .Cells(N, 4) = .[d1] .Cells(N, 5) = .[e1] Begin = Worksheets("期初余额").Cells(M, 3) '设定期初金额 For I = 2 To Worksheets("凭证明细表").Cells(Rows.Count, 1).End(3).Row '循环累计各项 If Worksheets("凭证明细表").Cells(I, 1) = .Cells(N, 1) Then '判断凭证明细表当前单元格内容是否与科目余额表当前单元格内容一致 If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) < DateValue(Year(mDate) & "-" & Month(mDate) & "-1") Then '判断是否当前日期为输入日期的上个月（含）之前的内容 Begin = Begin + Worksheets("凭证明细表").Cells(I, 10).Value - Worksheets("凭证明细表").Cells(I, 11).Value End If If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) <= mDate Then '判断当前日期是否是输入日期之前的内容 Total1 = Total1 + Worksheets("凭证明细表").Cells(I, 10) Total2 = Total2 + Worksheets("凭证明细表").Cells(I, 11) End If If Worksheets("凭证明细表").Cells(I, 5).Value = Year(mDate) Then '判断当前日期是否是输入日期当年的内容 If DateValue(Worksheets("凭证明细表").Cells(I, 5).Value & "-" & Worksheets("凭证明细表").Cells(I, 6).Value & "-" & Worksheets("凭证明细表").Cells(I, 7).Value) <= mDate Then '继续判断是否是输入日期之前的内容 yTotal1 = yTotal1 + Worksheets("凭证明细表").Cells(I, 10).Value yTotal2 = yTotal2 + Worksheets("凭证明细表").Cells(I, 11).Value End If If Worksheets("凭证明细表").Cells(I, 6).Value = Month(mDate) And Worksheets("凭证明细表").Cells(I, 7).Value <= Day(mDate) Then '继续判断是否是输入日期当月并且是当日之前的内容 mTotal1 = mTotal1 + Worksheets("凭证明细表").Cells(I, 10).Value mTotal2 = mTotal2 + Worksheets("凭证明细表").Cells(I, 11).Value End If End If End If Next I .Cells(N, 6) = Begin '写入累计结果 .Cells(N, 7) = mTotal1 .Cells(N, 8) = mTotal2 .Cells(N, 9) = yTotal1 .Cells(N, 10) = yTotal2 .Cells(N, 11) = Total1 .Cells(N, 12) = Total2 .Cells(N, 13) = Worksheets("期初余额").Cells(M, 3) + Total1 - Total2 N = N + 1 Next M .Columns("F:M").NumberFormatLocal = "0.00" '设置对应区域数值格式 .Range(Cells(2, 1), Cells(N - 1, 13)).Borders.LineStyle = 1 '数据区域加上网格线 End With Worksheets("科目余额表模板").Visible = xlSheetVeryHidden '隐藏模板 Application.ScreenUpdating = True End Sub 生成效果如下图：详见附件。通过凭证明细，自动生成明细账及科目余额表.rar
62楼梧桐小雨	很有意思。谢谢
63楼惜红衣	为什么我下载后打开，显示的是：编译错误：找不到工程或库菜鸟级别，请高手解释一下：）
64楼 xing768	谢谢了！为什么点击批量生成显示错误啊？批量生成和个别生成是什么意思？不好意思问这么简单的问题。
65楼 yardview	好东东大家分享，谢谢提供
66楼信合人	好东东大家分享，谢谢提供
67楼信合人	为啥链接不能用哦
68楼 jlsbg	是否根据记账凭证直接输入凭证明细表就可以了？历年借方累计历年贷方累计是怎样来的？有需要结转的怎样实现
69楼庭院幽幽	哦，好好学习，这些代码要研究一阵了
70楼 kekedoufeng513	学习！
71楼 lrlxxqxa
72楼 250949713	好贴！版主无私奉献，学习了！
73楼 yeminqiang	这个收藏吧，现在看不明白
74楼 VIP]_个人
75楼 sindy049	拿来试试，谢谢楼主，正找这个呢
76楼 pkpkyb	有意思的东西，学习学习！