一、代码优化问题说明

操作软件：Microsoft Office Excel 2021
使用功能：Visual Basic（开发工具--visualbasic编辑器--新建模块）

前期写过一篇《VBA实用基础程序 | 一键批量生成对账单》的文章，虽然可以帮助我一键批量生成对账单，大致上是能解决目前的问题，但是仍有一些后续问题有待解决。

由于一个客户我设计一个总的工作簿，每个月对账单对应的工作表都需要保存在同一个工作簿里。而目前代码所实现的只是将当月的对账单生成一个新的工作簿，而不会自动打开总的客户工作簿将当月的数据添加进去。

目前最笨的办法就是 ：先打开一个客户总的工作簿，然后再打开当月生成的对账单，复制粘贴到总的工作簿里，保存关闭。

上百家客户如此笨拙地操作下来，几个小时又没了。

所以接下来要解决的问题就是：

在生成对账单的过程中，如果是老客户，会自动按照客户名称找到总的工作簿，打开并把当月的数据添加进去。

如果是新客户的话，则是在模板工作簿所在的路径下生成新的对账单。

二、代码更新

1. 编写一个能自动访问客户往期对账单总表，打开、修改数据并保存的代码。

先设置一个for循环来遍历对账单总表文件夹里的文件，通过if函数判断文件名称是否存在于文件夹里。

如果存在的话，就表示该客户为老客户，然后对文件进行打开、修改、保存等操作。
如果不存在时，就表示该客户为新客户，后续对其进行另存为新对账单的操作。

'代码更新:
'如果是已经存在的老客户，找到往期对账单，将最新一期的数据添加进去
'如果是新客户，则重新生成对账单
Dim fso As New FileSystemObject '因为定义了FileSystemObject，所以要先在vb窗口中，选择工具-引用-勾选Microsoft Scripting Runtime
Dim objFile, objFolder
Dim pathw '定义变量，用于存储对账单总表的地址
Dim wt
pathw = "C:\Users\ZWYB\Desktop\程序编写文件夹\对账单总表\" '注意结尾处有"\"
Set objFolder = fso.GetFolder(pathw)For Each objFile In objFolder.Files '用一个for循环不断读取文件夹里面的文件If InStr(objFile.Name, arr1(k, 1)) = 1 Then '判断文件夹里面的文件名称是否为当前arr1数组中的名称，如果是则执行下面操作Set wt = Workbooks.Open(objFile.Path) '打开文件fzmb.Copy after:=Worksheets(Worksheets.Count) '复制模板内容到当前arr1(k, 1)所在的工作簿中Worksheets(arr1(k, 1)).Name = Format(Date, "mm月") '利用format函数获取当前月份，如果需要获取完整日期：yyyy年mm月dd日'Worksheets(arr1(k, 1)).Name = “9月” '备选：灵活选择按何种方式命名工作表的名称ActiveWorkbook.Save '保存ActiveWorkbook.Close '关闭Application.DisplayAlerts = False  '屏蔽警告窗口fzmb.Delete  '删除复制的模板Application.DisplayAlerts = True  '打开警告窗口        End IfNext

2. 新客户另存为独立对账单的代码。

在原来的代码中，已经有生成对账单的代码，在此基础上稍加修改即可。

用MsgBox函数 来提示是否有新客户的产生，当有新客户存在时，就会自动弹出提示选项框，通过选择“确定”或者“取消”来进行下一步操作。

当点击“确定”按钮时，系统就会自动将新客户的对账单表生成独立的工作簿，并保存在当前路径下。
当点击“取消”按钮时，不进行任何操作。

此外，所有新客户的工作表都保存完后，要在模板工作簿中将其删除，当工作表的名字不为“模板”和“榜单明细”时，执行删除操作。

'新客户对账单生成代码
Dim j%
Dim spath As String
answer = MsgBox("本月有新客户，是否生成对账单", vbYesNo + vbQuestion, "新客户对账单确认") '弹窗提示，是否需要生成新的对账单
If answer = vbYes Then '点击确定按钮Application.ScreenUpdating = False '禁止屏幕刷新spath = ThisWorkbook.Path & "\" '获取源文件夹路径   For j = 3 To ThisWorkbook.Sheets.Count '设置for循环，从第3个工作表开始自动另存为新的工作簿With ThisWorkbook.Sheets(j).Copy '复制工作表ActiveWorkbook.SaveAs spath & .Sheets(j).Name & ".xlsx" '将复制的工作表另存到当前路径下，并按工作表名称命名工作簿ActiveWorkbook.Close TrueEnd WithNext
'==============================================================
'当所有新的工作表都保存完后，在模板工作簿中将其删除Application.DisplayAlerts = False  '屏蔽警告窗口For Each fzmb In SheetsIf (fzmb.Name <> "模板") And (fzmb.Name <> "磅单明细") Then fzmb.Delete '当工作表的名字不为“模板”和“榜单明细”时，执行删除操作NextApplication.DisplayAlerts = True  '打开警告窗口
Else: '对应弹窗中的取消按钮，当选择“取消”时，不执行任何操作
End If

三、总的代码程序

Sub 一键生成对账单()Application.ScreenUpdating = False '屏幕刷新（ScreenUpdating），作用是使Excel停止刷新，提高代码的执行速度。
Application.DisplayAlerts = False '屏蔽弹窗提示Dim dqsh As Worksheet, fzmb As Worksheet, mb As Worksheet, sxrg As Range 'dqsh当前工作表 fzmb复制模板 mb模板 sxrg筛选
Dim wb As Workbook, y%, r%, x%, k%, i%, d '申明wb为工作簿对象 %短整型 d字典对象
Dim arr, arr1 '作为存储区域的数组
t = Timer '记录代码运行的起始时间Set d = CreateObject("scripting.dictionary") '创建字典对象
Set dqsh = ThisWorkbook.ActiveSheet '把当前工作簿的活动工作表交给dqsh
Set mb = Sheets("模板") '把模板这张工作表赋值给mbdqsh.AutoFilterMode = False '取消筛选，防止后面定位产生偏差r = dqsh.Range("J65536").End(xlUp).Row  '定位最后一行
arr = dqsh.Range("J3:J" & r)For x = 1 To UBound(arr)d(arr(x, 1)) = " "  '利用字典去重复值，一个客户名称只保留一个唯一值
Next xarr1 = Application.Transpose(d.keys)  '把字典中的客户名称转置后放到新数组arr1里
For k = 1 To UBound(arr1)dqsh.Range("J2").AutoFilter 10, arr1(k, 1) '筛选操作 AutoFilter 10 自动筛选第10列 arr1(k, 1)筛选的条件i = dqsh.Range("J3:J" & r).SpecialCells(xlCellTypeVisible).Cells.Count  '利用SpecialCells定位J列可见单元格的数量，然后赋值给变量imb.Copy after:=Sheets(Sheets.Count)  '赋值模板这张工作表Set fzmb = ActiveSheet  '把复制的模板交给变量fzmbfzmb.Name = arr1(k, 1)  '设置复制后的工作表名称fzmb.Range("a4").Resize(i).EntireRow.Insert  '在复制的模板里插入i行 EntireRow整行 Insert插入Set sxrg = dqsh.Range("A2").CurrentRegion  '把A2单元格所在的连续区域交给变量sxrg ，CurrentRegion 单元格的当前区域sxrg.Offset(2, 0).Resize(sxrg.Rows.Count - 2).Copy fzmb.Range("A4")    'Offset(2, 0)向下偏移2行，Rows.Count - 2 在原有的基础上减去后面2行空白行，复制好后粘贴到模板的A4单元格fzmb.Columns("I:M").Delete Shift:=xlToLeft    'Columns("K:O").Delete 删除模板中K列到O列的数据，Shift:=xlToLeft 表示删除单元格后，右面的单元格左移填充fzmb.Range("g" & i + 4) = "=sum(g4:g" & i + 3 & ")"    '动态求和，随着插入的行数自动变换，i4:i" & i + 3 & " 求和范围从I4单元格到I(i+3)单元格fzmb.Range("e" & i + 12) = "需方：" & arr1(k, 1)    '动态参数，若单元格是固定的，可写成 fzmb.Range("F12") = "供方：" & arr1(k, 1)fzmb.Range("A4").Select '定位到A4单元格，从A4单元格开始自动生成序列号For i = 1 To i '设置for循环，生成1到i的序列号ActiveCell.Value = i '将i的值交给当前激活的单元格ActiveCell.Offset(1, 0).Activate '向下偏移一行Next i' ==============================================================
'代码更新:
' 如果是已经存在的老客户，找到往期对账单，将最新一期的数据添加进去
'如果是新客户，则重新生成对账单Dim fso As New FileSystemObject '因为定义了FileSystemObject，所以要先在vb窗口中，选择工具-引用-勾选Microsoft Scripting Runtime
Dim objFile, objFolder
Dim pathw '定义变量，用于存储对账单总表的地址
Dim wtpathw = "C:\Users\ZWYB\Desktop\程序编写文件夹\对账单总表\" '注意结尾处有"\"
Set objFolder = fso.GetFolder(pathw)For Each objFile In objFolder.Files '用一个for循环不断读取文件夹里面的文件If InStr(objFile.Name, arr1(k, 1)) = 1 Then '判断文件夹里面的文件名称是否为当前arr1数组中的名称，如果是则执行下面操作Set wt = Workbooks.Open(objFile.Path) '打开文件fzmb.Copy after:=Worksheets(Worksheets.Count) '复制模板内容到当前arr1(k, 1)所在的工作簿中Worksheets(arr1(k, 1)).Name = Format(Date, "mm月") '利用format函数获取当前月份，如果需要获取完整日期：yyyy年mm月dd日'Worksheets(arr1(k, 1)).Name = “9月” '备选：灵活选择按何种方式命名工作表的名称ActiveWorkbook.Save '保存ActiveWorkbook.Close '关闭Application.DisplayAlerts = False  '屏蔽警告窗口fzmb.Delete  '删除复制的模板Application.DisplayAlerts = True  '打开警告窗口End IfNext'==============================================================y = y + 1  '每拆分一个客户就给变量y加上1，用于后面提示拆分的客户对账单总数
Next k  '继续对剩余客户执行上面同样的操作，直到把所有客户循环完' ==============================================================
'新客户对账单生成代码Dim j%
Dim spath As Stringanswer = MsgBox("本月有新客户，是否生成对账单", vbYesNo + vbQuestion, "新客户对账单确认") '弹窗提示，是否需要生成新的对账单
If answer = vbYes Then '点击确定按钮Application.ScreenUpdating = False '禁止屏幕刷新spath = ThisWorkbook.Path & "\" '获取源文件夹路径For j = 3 To ThisWorkbook.Sheets.Count '设置for循环，从第3个工作表开始自动另存为新的工作簿With ThisWorkbook.Sheets(j).Copy '复制工作表ActiveWorkbook.SaveAs spath & .Sheets(j).Name & ".xlsx" '将复制的工作表另存到当前路径下，并按工作表名称命名工作簿ActiveWorkbook.Close TrueEnd WithNext'==============================================================
' 当所有新的工作表都保存完后，在模板工作簿中将其删除Application.DisplayAlerts = False  '屏蔽警告窗口For Each fzmb In SheetsIf (fzmb.Name <> "模板") And (fzmb.Name <> "磅单明细") Then fzmb.Delete '当工作表的名字不为“模板”和“榜单明细”时，执行删除操作NextApplication.DisplayAlerts = True  '打开警告窗口Else: '对应弹窗中的取消按钮，当选择“取消”时，不执行任何操作End If'==============================================================dqsh.AutoFilterMode = False  '取消筛选
dqsh.Select  '回到账单主表
Application.ScreenUpdating = True  '打开屏幕刷新
MsgBox "对账单已拆分完成，一共生成" & y & "个对账单，一共用时" & Timer - t & "秒"  '通过msgbox弹出提示框End Sub

Excel VBA | 一键批量生成对账单（功能优化版本）相关推荐

Excel与bat批量生成文件夹，修改文件夹名称
用Excel与bat批量生成文件夹,修改文件夹名称一.批量生成文件夹 excel一列输入文件名序列:另一列用公式生成要写入bat文件的序列,之后复制该列写入.txt文件,保存为.bat文件,双击运行 ...
利用Pajek软件批量处理excel数据，批量生成网络关系图
利用Pajek软件批量处理excel数据,批量生成网络关系图 Pajek软件大家想必都不陌生,但是我很陌生,因为我用它不是进行网络分析,而是用它来画关系图(类似网络图).但是Pajek软件手工操作时一 ...
datatable如何生成级联数据_如何把Excel表数据批量生成条形码
条形码属于一维条码,是将宽度不等的多个黑条和空白,按照一定的编码规则排列,用以表达一组信息的图形标识符,条形码的种类比较多,比如常用的Code128码,Code39码,Code93码,EAN-13码, ...
Python+Excel+VBA实现批量自助生成名牌
文章目录需求在Excel制作名牌批量导出图片 1. 全VBA 2. VBA+压缩包 3. Python+Excel 打包需求这次是hrbp小姐姐需要找我批量生成他们新部门的员工名牌.如果让设 ...
[Excel VBA]如何批量產出QRcode?
QRcode常應用於產品上,不論是為了控管產品工序節點.或是控管產品售後質量,甚至是為了觸及更多消費者的行銷推廣活動.然而,QRcode標籤的產出往往受制於標籤設備的應用程式(當然也有不少方式可以解, ...
Python自动化办公:读取Excel数据并批量生成合同，高效办公，快速回家
前言在我们的工作中,面临着大量的重复性工作,通过人工方式处理往往耗时耗力易出错.而Python在自动化办公方面具有极大的优势,可以解决我们工作中遇到的很多重复性问题,分分钟搞定办公需求.快速下班回 ...
使用python 将excel中数据批量生成word周报
使用python 将excel中数据调用word模板批量生成word周报背景环境功能需求程序实现背景日常项目中每周需要召开项目周会,会议纪要和会议周报是必不可少的一项内容,会议纪要要求监理 ...
获取子文件夹后缀_后期制作老司机教你一键批量生成项目文件夹
我猜你的项目工程是这样的,当你老板说去修改一下之前几个月的工程的时候,你都不知道哪个工程才是最终版呀. 乱糟糟的工程而且当你打开工程的时候,wo艹,素材怎么丢失了~~ 不管是后期制作者还是平常我们日 ...
Excel如何快速批量生成指定性别的随机姓名
在工作中我们可能要生成指定性别的随机姓名,比如生成男性的姓名或者女性的姓名.下面就给大家分享一种快速方法.(下图为完成操作过程) 1.如下图,我们要快速批量生成男生姓名和女生姓名. 2.点击DIY工具 ...
Excel·VBA一键计算每月合计
<vba吧提问-怎么写每月合计的代码>,对表格中每月合计的行进行计算 Sub 选中列每月合计()'适用单/多列选中.单/多列部分选中Dim rng As Range, first_row, ...

Excel VBA | 一键批量生成对账单（功能优化版本）

文章目录