本文于2023年9月4日首发于本人同名其他平台，更多文章案例请搜索关注！
内容提要
总表按项目拆分到明细表
生成特定格式对账单
大家好，我是冷水泡茶，前几天在EXCELHOME论坛上看到一个网友的求助贴，怎么按模板拆分明细表？
关于总表拆分表明细表，我们分享过一个应用【Excel VBA 文件拆分工具】，我们已经考虑了多种情况了，但是实际工作中的需求真是千变万化，难以穷尽的，这不，楼主的需求是这样的：
1、明细表（总表）：
2、模板（分表）：
图中圈起来的地方，我觉得应该是自动取数的地方，虽然楼主没有明说。他这个跟我们分享过的一个案例有类似的地方【Excel VBA 债券交易审批单打印模板】，都是从明细数据中提取符合条件的数据，填写到特定格式的模板中。
楼主要求是按照“法人”拆分成一个一个工作表，如果仅仅是这样，我本来是不打算去掺和的，但是，我想到既然是“通知单”，是不是应该把文件发给对方？那么是不是应该导出一个个单独的文件？我猜楼主可能是把拆分好的工作表再保存为单独的文件。既然这样，我们何不一步到位，直接导出为一个个独立的文件？
经过几天的努力，终于达成目标，在这里分享给大家：
基本思路与设置过程：
1、设置一个用户窗体，把一些查询条件都放在窗体上：
2、把明细数据装入数组，利用字典，提取所有法人的名称，字典的item统计当前法人的记录数。
3、循环字典的key，再循环数组，提取相应明细数据。
4、复制模板为wsTarget，目标工作表。
5、把明细数据写入wsTarget。
6、我们设置两种方式，一种是保存在当前工作表，我们会删除原来的同名工作表，再插入新的工作表。一种是保存为独立的文件，我们就建立新的工作簿，把模板复制过去，再写入数据，然后保存，同样会覆盖原有同名工作簿，关闭新建的工作簿。
VBA代码
1、在UserForm1，UserForm_Initialize窗体初始化：
Dim saveFolder As StringDim dic As ObjectDim arrDetail(), arr1(), arr2()Dim wb As Workbook, newwb As WorkbookDim ws As WorksheetDim wsDetail As WorksheetDim wsSource As WorksheetDim dKey As StringDim lastRow As IntegerDim fileName As StringDim tbFirstLine As Integer '第一个表格第1行，编号为1Dim tbLastLine As Integer '第一个表格最后一行,编号为3Dim tbFirstLine2 As Integer '第二个表格第1行，编号为1Dim tbLastLine2 As Integer '第二个表格最后一行,编号为3Dim 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 = TrueEnd Sub
代码解析：
（1）定义一些模块级变量，放在过程外面，有些变量需要在其他过程使用。有工作表簿、工作对象ws，数组，字典等。
（2）窗体启动后，我们把明细数据读入数组，通过字典取得法人列表，赋值给cmbPresident的list，把两个月份的list设置为1月份、2月份......，12月份，这两个月份跟明细数据无关。把文件保存路径设置为当前文件所在文件夹。
2、在UserForm1，CmdConfirm_Click确认生成按钮：
Private Sub CmdConfirm_Click() Application.ScreenUpdating = False Dim extraLines As Integer 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 ReDim arr1(1 To dic(Key), 1 To 12) ReDim arr2(1 To dic(Key), 1 To 3) For i = 2 To UBound(arrDetail) If arrDetail(i, 1) = Key Then 'Stop k = k + 1 For m = 2 To 13 arr1(k, m - 1) = arrDetail(i, m) Next arr2(k, 1) = arrDetail(i, 2) arr2(k, 2) = arrDetail(i, 14) arr2(k, 3) = arrDetail(i, 15) End If Next If Me.OptCurrentTable Then Call CopyWorksheet(wsSource, fileName) Set wsTarget = wb.Sheets(fileName) extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1) If extraLines > 0 Then With wsTarget .Range("B3") = Key .Range("A5") = Me.CmbCurrentMonth .Range("F5") = Me.CmbDeadLine .Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine, 2).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 .Rows(tbFirstLine2 + 1 + extraLines & ":" & tbFirstLine2 + extraLines + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine2 + extraLines, 2).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 For j = 1 To dic(Key) .Cells(tbFirstLine + j - 1, 1) = j .Cells(tbFirstLine2 + extraLines + j - 1, 1) = j Next memoLine = tbLastLine2 + 4 + IIf(extraLines > 0, extraLines * 2, 0) .Cells(memoLine, 1) = "请各位法人于" & Me.CmbCurrentMonth & "缴完应付额" End With End If 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) If extraLines > 0 Then With wsTarget .Range("B3") = Key .Range("A5") = Me.CmbCurrentMonth .Range("F5") = Me.CmbDeadLine .Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine, 2).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 .Rows(tbFirstLine2 + 1 + extraLines & ":" & tbFirstLine2 + extraLines + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine2 + extraLines, 2).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 For j = 1 To dic(Key) .Cells(tbFirstLine + j - 1, 1) = j .Cells(tbFirstLine2 + extraLines + j - 1, 1) = j Next memoLine = tbLastLine2 + 4 + IIf(extraLines > 0, extraLines * 2, 0) .Cells(memoLine, 1) = "请各位法人于" & Me.CmbCurrentMonth & "缴完应付额" End With End If Application.DisplayAlerts = False wb.SaveAs Me.TxbFilePath & "\" & Key & ".xlsx" Application.DisplayAlerts = True wb.Close End If Next Else '未选择法人，则生成所有法人的 k = 0 fileName = Me.CmbPresident ReDim arr1(1 To dic(fileName), 1 To 12) ReDim arr2(1 To dic(fileName), 1 To 3) For i = 2 To UBound(arrDetail) If arrDetail(i, 1) = fileName Then 'Stop k = k + 1 For m = 2 To 13 arr1(k, m - 1) = arrDetail(i, m) Next arr2(k, 1) = arrDetail(i, 2) arr2(k, 2) = arrDetail(i, 14) arr2(k, 3) = arrDetail(i, 15) End If Next If Me.OptCurrentTable Then Call CopyWorksheet(wsSource, fileName) Set wsTarget = wb.Sheets(fileName) extraLines = UBound(arr1) - (tbLastLine - tbFirstLine + 1) If extraLines > 0 Then With wsTarget .Range("B3") = fileName .Range("A5") = Me.CmbCurrentMonth .Range("F5") = Me.CmbDeadLine .Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine, 2).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 .Rows(tbFirstLine2 + 1 + extraLines & ":" & tbFirstLine2 + extraLines + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine2 + extraLines, 2).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 For j = 1 To dic(fileName) .Cells(tbFirstLine + j - 1, 1) = j .Cells(tbFirstLine2 + extraLines + j - 1, 1) = j Next memoLine = tbLastLine2 + 4 + IIf(extraLines > 0, extraLines * 2, 0) .Cells(memoLine, 1) = "请各位法人于" & Me.CmbCurrentMonth & "缴完应付额" End With End If 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) If extraLines > 0 Then With wsTarget .Range("B3") = fileName .Range("A5") = Me.CmbCurrentMonth .Range("F5") = Me.CmbDeadLine .Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine, 2).Resize(UBound(arr1), UBound(arr1, 2)) = arr1 .Rows(tbFirstLine2 + 1 + extraLines & ":" & tbFirstLine2 + extraLines + extraLines).Insert Shift:=xlDown .Cells(tbFirstLine2 + extraLines, 2).Resize(UBound(arr2), UBound(arr2, 2)) = arr2 For j = 1 To dic(fileName) .Cells(tbFirstLine + j - 1, 1) = j .Cells(tbFirstLine2 + extraLines + j - 1, 1) = j Next memoLine = tbLastLine2 + 4 + IIf(extraLines > 0, extraLines * 2, 0) .Cells(memoLine, 1) = "请各位法人于" & Me.CmbCurrentMonth & "缴完应付额" End With End If Application.DisplayAlerts = False wb.SaveAs Me.TxbFilePath & "\" & fileName & ".xlsx" Application.DisplayAlerts = True wb.Close End If End If MsgBox "Done!" wsSource.Visible = False Unload Me Application.ScreenUpdating = TrueEnd Sub
代码解析：代码比较多，有180行。
（1）定义一些变量，extraLines额外的行，模板中设置了3行，如果超过3行，我们就要插入行，这个操作还是比较麻烦的，主要有两个地方需要插入行。
（2）line6~13，检查两个月份是否为空，月份为必选项。
（3）line14~16，检查法人是否选择，当法人没有选择时，给出一个提示，如果不选，则生成所有法人的通知应付单。
（4）line19~37，计算模板中两个表格数据行的起始位置，为下面需要插入行时作为基础。
（5）line38~108，当未选具体法人时，生成所有法人的通知单。通过循环字典的keys，根据当前key的item值定义两个数组arr1，arr2，循环明细表数组arrDetail，把符合条件的数据写入数组。根据选项按钮，决定是存入当前工作表还是新建独立文件。根据数组的行数计算额外行的数量，决定是否需要在新的工作表中插入行。插入行后，把数组数据、以及一些相关字段写入新建的工作表。
（6）line109~177，当选择了具体法人时，就根据当前法人提取数据，跟上面操作基本相仿。
（7）line179，把模板表隐藏（防止误操作改变模板表结构）。
3、在UserForm1，其他过程：
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 IfEnd SubPrivate Sub OptCurrentTable_Change() If OptCurrentTable Then Me.Frame1.Visible = False End IfEnd SubPrivate Sub OptNewSingleFile_Change() If OptNewSingleFile Then Me.Frame1.Visible = True End IfEnd SubPrivate Sub CmdExit_Click() Unload MeEnd Sub
代码解析：
（1）line1~14，文件路径文本框双击事件，双击选择更改文件保存目录。
（2）line16~20，选项“当前文件”的change事件，如果它的值为True，则隐藏框架Frame1，文件保存在当前文件中。
（3）line22~24，选项“独立文件”的change事件，如果它的值为True，则显示框架Frame1，供选择文件保存路径。
（4）line28~30，退出窗体。
4、在UserForm1，几个自定义函数：
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 WithEnd FunctionPrivate Function IsFolderExists(strFolder As String) As Boolean Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.folderexists(strFolder) Then IsFolderExists = True End IfEnd FunctionPrivate 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 = vbYesEnd FunctionSub 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 = wsNameEnd Sub
代码解析：这几个函数我们前面都分享过。
（1）line1~10，文件路径路径选择。
（2）line12~18，检查文件夹是否存在。
（3）line20~27，确认继续函数，防止误点按钮。
（4）line29~46，复制工作表函数，在同一个工作簿中，把一个工作表复制为指定名称的工作表，如果已存在同名工作表的，则先删除同名工作表。
5、工作表“Main”。
Private Sub CmdBilling_Click() UserForm1.ShowEnd SubPrivate Sub CmdShowTemplate_Click() MsgBox "模板请勿随意修改！可设置单元格格式。" Set ws = ThisWorkbook.Sheets("模版") ws.Visible = True ws.ActivateEnd Sub
代码解析：
（1）line1~3，“通知应付单”命令按钮，启动用户窗体。
（2）line5~10，显示“模版”表。在生成通知应付单后，我们会隐藏“模版”表，如果需要修改模版”表单元格格式的（字体、行列间距什么的，其他文字不能随意修改），我们点击“显示模版”命令按钮来显示工作表。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！
注：本文部分代码有bug，后期有更新。