本文于2023年9月22日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
更正优化后的完整代码
1、在Main工作表中，两个命令按钮：
Private Sub CmdBilling_Click()
UserForm1.Show
End Sub
Private Sub CmdShowTemplate_Click()
MsgBox "模板请勿随意修改！可设置单元格格式。"
Set ws = ThisWorkbook.Sheets("模版")
ws.Visible = True
ws.Activate
End Sub
2、在UserFor1里，定义变量与窗体初始化：
Dim saveFolder As String
Dim dic As Object
Dim arrDetail(), arr1(), arr2()
Dim wb As Workbook, newwb As Workbook
Dim ws As Worksheet
Dim wsDetail As Worksheet
Dim wsSource As Worksheet
Dim dKey As String
Dim lastRow As Integer
Dim fileName As String
Dim tbFirstLine As Integer '第一个表格第1行，编号为1
Dim tbLastLine As Integer '第一个表格最后一行,编号为3
Dim tbFirstLine2 As Integer '第二个表格第1行，编号为1
Dim tbLastLine2 As Integer '第二个表格最后一行,编号为3
Dim extraLines As Integer
Dim Key As Variant
Dim memoLine As Integer '最后一条文本
Private Sub UserForm_Initialize()
Set dic = CreateObject("Scripting.Dictionary")
Set wsDetail = ThisWorkbook.Sheets("明细")
lastRow = wsDetail.UsedRange.Rows.Count
arrDetail = wsDetail.Range("A1:O" & lastRow).Value
For i = 2 To UBound(arrDetail)
If arrDetail(i, 1) <> "" Then
dKey = arrDetail(i, 1)
dic(dKey) = dic(dKey) + 1
End If
Next
Me.CmbCurrentMonth.Clear
Me.CmbDeadLine.Clear
Me.CmbPresident.Clear
For i = 1 To 12
Me.CmbCurrentMonth.AddItem i & "月份"
Me.CmbDeadLine.AddItem i & "月份"
Next
Me.CmbPresident.List = dic.keys
Me.TxbFilePath = ThisWorkbook.Path
Me.OptCurrentTable = True
End Sub
3、在UserFor1里，“生成”按钮：
Private Sub CmdConfirm_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim wsTarget As Worksheet
Set wb = ThisWorkbook
If Me.CmbCurrentMonth = "" Then
MsgBox "请选择账单月份"
Exit Sub
End If
If Me.CmbDeadLine = "" Then
MsgBox "请选择最晚月份"
Exit Sub
End If
If Me.CmbPresident = "" Then
If Not wContinue("未选择法人，将生成所有法人的对账单！") Then Exit Sub
End If
Set wsSource = ThisWorkbook.Sheets("模版")
wsSource.Visible = True
With wsSource
lastRow = .UsedRange.Rows.Count
For i = 1 To lastRow
If .Cells(i, 1) = "编号" Then
tbFirstLine = i + 1
ElseIf .Cells(i, 1) = "小计" Then
tbLastLine = i - 1
Exit For
End If
Next
For i = lastRow To 1 Step -1
If .Cells(i, 1) = "小计" Then
tbLastLine2 = i - 1
ElseIf .Cells(i, 1) = "编号" Then
tbFirstLine2 = i + 1
Exit For
End If
Next
End With
If Me.CmbPresident = "" Then
'未选择法人，则生成所有法人的
For Each Key In dic.keys
k = 0
fileName = Key
Call WriteArray(arr1, arr2)
If Me.OptCurrentTable Then
Call CopyWorksheet(wsSource, fileName)
Set wsTarget = wb.Sheets(fileName)
extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1)
Call WriteData(wsTarget)
Else
Set wb = Workbooks.Add
wsSource.Copy before:=wb.Sheets(1)
Set wsTarget = wb.Sheets(1)
wsTarget.Name = Key
extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1)
Call WriteData(wsTarget)
For Each ws In wb.Worksheets
If ws.Name <> Key Then
ws.Delete
End If
Next
wb.SaveAs Me.TxbFilePath & "\" & Key & ".xlsx"
wb.Close
End If
Next
Else
'选择法人，则生成所选法人的
k = 0
fileName = Me.CmbPresident
Call WriteArray(arr1, arr2)
If Me.OptCurrentTable Then
Call CopyWorksheet(wsSource, fileName)
Set wsTarget = wb.Sheets(fileName)
extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1)
Call WriteData(wsTarget)
Else
Set wb = Workbooks.Add
wsSource.Copy before:=wb.Sheets(1)
Set wsTarget = wb.Sheets(1)
wsTarget.Name = fileName
extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1)
Call WriteData(wsTarget)
For Each ws In wb.Worksheets
If ws.Name <> fileName Then
ws.Delete
End If
Next
wb.SaveAs Me.TxbFilePath & "\" & fileName & ".xlsx"
wb.Close
End If
End If
MsgBox "Done!"
wsSource.Visible = False
Unload Me
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
4、在UserFor1里，两个新增的独立过程：
Sub WriteArray(arr1(), arr2())
ReDim arr1(1 To dic(fileName), 1 To 13)
ReDim arr2(1 To dic(fileName), 1 To 4)
For i = 2 To UBound(arrDetail)
If arrDetail(i, 1) = fileName Then
k = k + 1
For m = 2 To 13
arr1(k, m) = arrDetail(i, m)
Next
arr1(k, 1) = k
arr2(k, 1) = k
arr2(k, 2) = arrDetail(i, 2)
arr2(k, 3) = arrDetail(i, 14)
arr2(k, 4) = arrDetail(i, 15)
End If
Next
End Sub
Sub WriteData(ws As Worksheet)
'把数据写入工作表
With ws
If extraLines > 0 Then
.Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown
.Rows(tbFirstLine2 + 1 + extraLines & ":" & tbFirstLine2 + extraLines + extraLines).Insert Shift:=xlDown
Else
extraLines = 0
End If
.Range("B3") = Key
.Range("A5") = Me.CmbCurrentMonth
.Range("F5") = Me.CmbDeadLine
.Cells(tbFirstLine, 1).Resize(UBound(arr1), UBound(arr1, 2)) = arr1
.Cells(tbFirstLine2 + extraLines, 1).Resize(UBound(arr2), UBound(arr2, 2)) = arr2
memoLine = tbLastLine2 + 4 + extraLines * 2
.Cells(memoLine, 1) = "请各位法人于" & Me.CmbCurrentMonth & "缴完应付额"
End With
End Sub
5、在UserFor1里，其他过程与自定义函数：
Private Sub TxbFilePath_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim preFolder As String
preFolder = Me.TxbFilePath
If Not IsFolderExists(preFolder) Then
preFolder = ThisWorkbook.Path
End If
saveFolder = PathSelected
If Not saveFolder = "" Then
Me.TxbFilePath = saveFolder
Else
saveFolder = preFolder
Me.TxbFilePath = saveFolder
End If
End Sub
Private Sub OptCurrentTable_Change()
If OptCurrentTable Then
Me.Frame1.Visible = False
End If
End Sub
Private Sub OptNewSingleFile_Change()
If OptNewSingleFile Then
Me.Frame1.Visible = True
End If
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Function PathSelected()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框
PathSelected = .SelectedItems(1)
Else
Exit Function
End If
End With
End Function
Private Function IsFolderExists(strFolder As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.folderexists(strFolder) Then
IsFolderExists = True
End If
End Function
Private Function wContinue(Msg) As Boolean
'确认继续函数
Dim Config As Long
Config = vbYesNo + vbDefaultButton2 + vbQuestion
Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) _
& "否(N)返回！", Config, "请确认操作！")
wContinue = Ans = vbYes
End Function
Sub CopyWorksheet(sourceWorksheet As Worksheet, wsName As String)
Dim targetWorksheet As Worksheet
'检查是否存在同名的目标工作表，如果存在则删除
On Error Resume Next
Set targetWorksheet = ThisWorkbook.Worksheets(wsName)
On Error GoTo 0
If Not targetWorksheet Is Nothing Then
Application.DisplayAlerts = False
targetWorksheet.Delete
Application.DisplayAlerts = True
End If
'复制源工作表到同一个工作簿
sourceWorksheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'获取新复制的工作表的引用
Set targetWorksheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'重命名新复制的工作表
targetWorksheet.Name = wsName
End Sub
代码就不解释了，新增与修改的部分在第一条文章中基本说得差不多了。
没有变化的，可以参见原文【Excel VBA 批量自动生成应收款对账单/应付通知单】
回头检查看了一篇，好象还有优化的空间，比如计算extraLines这句代码可以移到
Call WriteArray(arr1, arr2)下面，又可以减少两行，时间关系，不去折腾了，就这样吧。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！