Excel VBA【案例】表格拆分：按照固定模板把不同代理人分别保存文件并打印

快速浏览

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

实用案例

|日期控件||简单的收发存||收费管理系(Access改进版)|

|电子发票管理助手||电子发票登记系统(Access版)|

|文件合并||表格拆分||审计凭证抽查底稿|

|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|

收费使用项目

|财务管理系统||工资薪金和年终奖个税筹划|

内容提要

• Excel表格拆分

大家好，我是冷水泡茶，前两天看到一个求助：

[求助] Excel表根据指定数据自动填入固定模板，自动选地方另存、预览和批量打印

他的数据表是这样的：

列表：

模板：

他的基本需求是把列表中的代理人分别筛选出来，填到模板表里，保存文件、打印。

他的具体要求是：

他这个要求还蛮多。关于表格拆分，模板打印，我们分享过很多【批量自动生成应收款对账单】、【销货小票批量打印】 、【债券交易审批单打印模板】、【Excel表格拆分神器】等等，本来我是没打算做这个案例的，但是为了写公众号文章，没有其他合适的案例，就拿它来处理一下，权当复习了。

基本思路：

1、运用字典提取不重复的代理人。

2、设置一个数组存放所有需要的数据。

3、循环字典的Key，把item取出来存到一个数组。

4、把这个数组写入工作表（模板），另存为一个新的文件。

5、设置一个公共变量proType，用来存放点击命令按钮的名称，据以判断是否打印文件。

VBA代码

1、在myModule里，mySplit过程：

Public proType As String  '定义一个公共变量，判断要不要打印Sub mySplit()    Dim arrTem(), wb As Workbook    Dim ws As Worksheet, wsTarget As Worksheet    Dim arr()    dim dic As Object, dKey As String    Dim saveFolder As String, fileName As String    Dim iRows As Integer, k As Integer, i As Integer    Dim grandTotal As Double    Set ws = ThisWorkbook.Sheets("列表")    Set dic = CreateObject("Scripting.Dictionary")    Application.DisplayAlerts = False    '略过警告信息，如覆盖已有文件。    Application.ScreenUpdating = False   '停止屏幕刷新    If proType = "打印" Then   '如果点击了“打印”命令按钮，选择打印机。        If Application.Dialogs(xlDialogPrinterSetup).Show = False Then            Exit Sub        End If    End If    With Application.FileDialog(msoFileDialogFolderPicker) '选择文件夹        .Title = "请选择保存文件夹......"        If .Show = -1 Then            saveFolder = .SelectedItems(1)        Else            MsgBox "请选择文件保存文件夹！"            Exit Sub        End If    End With    arr = ws.UsedRange   '把列表装入数组    For i = 2 To UBound(arr)  '循环数组        dKey = arr(i, Pxy(arr, "代理人", 2))  '代理人作为字典的Key。        If Not dic.exists(dKey) Then  '如果dkey不存在            k = 0        Else            arrTem = dic(dKey)            k = UBound(arrTem, 2) + 1        End If        '写入数组        ReDim Preserve arrTem(0 To 9, 0 To k)        arrTem(0, k) = k + 1        arrTem(1, k) = arr(i, Pxy(arr, "代理人", 2))        arrTem(2, k) = arr(i, Pxy(arr, "收付单号", 2))        arrTem(3, k) = arr(i, Pxy(arr, "不含税业务金额", 2))        arrTem(4, k) = arr(i, Pxy(arr, "系统手续费", 2))        arrTem(5, k) = arr(i, Pxy(arr, "系统手续费", 2))        arrTem(6, k) = arrTem(3, k) - arrTem(4, k)        arrTem(7, k) = arr(i, Pxy(arr, "收款人", 2))        arrTem(8, k) = arr(i, Pxy(arr, "开户行", 2))        arrTem(9, k) = arr(i, Pxy(arr, "收款人账号", 2))        dic(dKey) = arrTem   '把数组存入字典    Next    For Each Key In dic.keys  '循环字典的key        grandTotal = 0        Set ws = ThisWorkbook.Sheets("模板")        ws.Copy  '复制模板到新的工作簿        Set ws = ActiveSheet        With ws            .Name = Key   '工作表名称            arrTem = dic(Key)    '当前key的Item存入数组，它原来就是一个数组。            For i = 0 To UBound(arrTem, 2)                grandTotal = grandTotal + Round(CDbl(arrTem(6, i)), 2)            Next            fileName = Key & "（" & Format(grandTotal, "Standard") & "）.xlsx"    '保存的文件名            iRows = UBound(arrTem, 2) + 1  '记录的行数，判断要不要插入行            If iRows > 1 Then  '如果多于1行，则插入行                .Rows("5:" & 5 + iRows - 2).Insert shift:=xlDown            End If            With .Range("A4").Resize(iRows, 10)  '数据区域                .Columns(3).NumberFormatLocal = "@"   '设置账号栏文本，下同                .Columns(10).NumberFormatLocal = "@"                '把数组写入工作表                .Cells(1, 1).Resize(UBound(arrTem, 2) + 1, 10) = _                    Application.WorksheetFunction.Transpose(arrTem)                .Cells(iRows + 1, 4).Resize(1, 4) = _                    "=sum(" & .Columns(4).Address(0, 0) & ")"                .Cells(1, 4).Resize(iRows + 1, 4).NumberFormatLocal = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""??_ ;_ @_ "            End With        End With        If proType = "打印" Then            ws.PrintOut copies:=1        End If        Set wb = ActiveWorkbook        wb.SaveAs saveFolder & "\" & fileName        wb.Close    Next    Application.DisplayAlerts = True    Application.ScreenUpdating = True    MsgBox "Done!"End Sub

代码解析：（代码中亦有注释）

（1）line1，定义一个公共变量preType ，用来存放点击的命令按钮的名称，据以判断是否打印。

（2）line3~9，定义变量。

（3）line14~18，如果点击的是“打印“按钮，则启动打印机选择对话框。

（4）line19~27，选择文件保存文件夹。

（5）line29~50，循环数组arr，以第2列代理人为字典的Key，以数组arrTem作为Item保存数据。

（6）line51~84，循环字典的key，把数据写入模板，以代理人+实发金额合计为文件名，如果点击的是打印按钮，则打印工作表，保存关闭。

2、在myModule里，Pxy自定义函数：

Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    'arrType=0,表示一维数组    'arrType=1,表示二维数组，查找第一列    'arrType=2,表示二维数组，查找第一行    '**********************************    k = 0    t = 0    Select Case arrType    Case Is = 0        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function

代码解析：数组字段定位，根据字段名称来取得数组下标，比直接写数字要灵活。

3、在工作表“列表”里，两个命令按钮：

Private Sub CmdPrint_Click()    proType = "打印"    Call mySplitEnd Sub
Private Sub CmdSplit_Click()    proType = "拆分"    Call mySplitEnd Sub

代码解析：

（1）“拆分”按钮，按代理人拆分并保存文件。

（2）“打印”按钮，按代理人拆分保存文件，并打印。

总结

1、把将数据写入数组arrTem的代码作了优化，前面的案例中，在判断字典的key是否存在的时候，在IF语句的两个分支中均有写入数组的代码，现在把它移到IF语句外面来，减少重复代码。

2、使用“模板”，可以预先设置好格式，复制使用，比较方便；也可以把模板表格的相关内容，表头、表尾的固定文字写在代码中，格式也用代码来控制，可以不需要“模板”这张表。

3、拆分表格，当以原表格式拆分时，我们也可以采用工作表筛选的方法，不过今天的例子原表与模板的格式不同，不适用筛选的方法。

好，今天就到这，我们下期再会。

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