Excel VBA 批量自动生成应收款对账单/应付通知单

快速浏览

往期合集：【2023年3月】【2023年4月】【2023年5月】【2023年6月】【2023年7月】【2023年8月】

实用案例

|日期控件||简单的收发存|

|电子发票管理助手|

|电子发票登记系统(Access版)|

|Excel多种类型文件合并|

|Excel表格拆分神器|

|批量生成审计凭证抽查底稿|

|中医诊所收费系统(Excel版)|

|中医诊所收费系统(Access版)|

|收费管理系(Access改进版)|

收费使用项目

|财务管理系统|

内容提要

• 总表按项目拆分到明细表
• 生成特定格式对账单

大家好，我是冷水泡茶，前几天在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 Sub
Private Sub OptCurrentTable_Change()    If OptCurrentTable Then        Me.Frame1.Visible = False    End IfEnd Sub
Private Sub OptNewSingleFile_Change()    If OptNewSingleFile Then        Me.Frame1.Visible = True    End IfEnd Sub
Private 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 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 IfEnd 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 = vbYesEnd 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 = wsNameEnd Sub

代码解析：这几个函数我们前面都分享过。

（1）line1~10，文件路径路径选择。

（2）line12~18，检查文件夹是否存在。

（3）line20~27，确认继续函数，防止误点按钮。

（4）line29~46，复制工作表函数，在同一个工作簿中，把一个工作表复制为指定名称的工作表，如果已存在同名工作表的，则先删除同名工作表。

5、工作表“Main”。

Private Sub CmdBilling_Click()    UserForm1.ShowEnd Sub
Private Sub CmdShowTemplate_Click()    MsgBox "模板请勿随意修改！可设置单元格格式。"    Set ws = ThisWorkbook.Sheets("模版")    ws.Visible = True    ws.ActivateEnd Sub

代码解析：

（1）line1~3，“通知应付单”命令按钮，启动用户窗体。

（2）line5~10，显示“模版”表。在生成通知应付单后，我们会隐藏“模版”表，如果需要修改模版”表单元格格式的（字体、行列间距什么的，其他文字不能随意修改），我们点击“显示模版”命令按钮来显示工作表。

来一个动画演示

~~~~~~End~~~~~~

喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！

需要示例文件的朋友请稍微留意一下：

• 写文不易，分享免费，请关注、点赞、点在看、点广告、留言，如果不愿走上面的“流程”，打赏也行，万分感谢！