VBA-将汇总表按指定条件拆分

需求

汇总表部分截取如下：

现需要把其中内容按订单日期、收货地区、供应商三个条件拆分成可独立成页的审批表，审批表表头含有公共信息，额外含有供应商联系人及联系方式。审批表模板如下：

最终效果：

分析

1、拆分条件

每份审批表的订单日期、收货地区、供应商都相同，优先级为：订单日期>收货地区=供应商。当按行遍历数据源，某行数据的订单日期、收货地区、供应商其中之一与上行数据相比发生改变时，新建审批表。

2、执行流程

• 从数据源读取一行数据，进入判定
• 判定 1：日期改变。插入签名行和分页符，新建审批表表头
• 判定 2：收货地区改变。插入签名行和分页符，新建审批表表头，日期、供应商不变
• 判定 3：供应商改变。插入签名行和分页符，新建审批表表头，日期、收货地区不变
• 插入数据源数据

3、注意事项

定义一个全局变量 desRowCur，指示目标表当前可操作的行号，初始值为 1，每当有插入操作（包括新建表头）时自增。

4、其他细节

• 将新建表头的操作独立成过程，减少重复代码（actionAndGetRowCur）
• 将写入行数据到目标表独立成过程，使流程逻辑清晰（writeDataAndGetRowCur）
• 将从模板复制区域到目标表的操作独立成过程，减少重复代码（copyRangFromOrigin）
• 建立函数，根据供应商名称返回联系人（getManufacturerContactName）
• 建立函数，根据收货地区简称补齐全称以及对直辖市名称的特殊处理（getDemandSideAllName）

解决方案

实现代码如下：

main

Sub main()

    Dim origin As Worksheet
    Set origin = Worksheets("发货情况汇总台账（数据源）")
    
    '填充模板-1
    Dim templateType As Integer: templateType = 1
    
    '目标表当前可操作行
    Dim desRowCur As Integer: desRowCur = 1
    
    '数据源每行日期
    Dim dateOriginCur As String: dateOriginCur = ""
    '数据源每行收货地区
    Dim demandSideOriginCur As String: demandSideOriginCur = ""
    '数据源每行供应商
    Dim manufacturerNameOriginCur As String: manufacturerNameOriginCur = ""
    
    '数据源行号
    Dim rowIndexOrigin As Integer
    '遍历数据源，从第三行开始
    For rowIndexOrigin = 3 To 5000
        '到达文件结尾
        If origin.Range("B" & rowIndexOrigin).Value = "" Then
            '复制签名行
            Call copyRangFromOrigin("A6:I6", "A" & desRowCur & ":I" & desRowCur)
            Exit For
        End If
    
        '【日期】变化-新建
        If dateOriginCur <> origin.Range("B" & Trim(Str(rowIndexOrigin))).Value Then
            '当不是第一行时才插入分页符
            If desRowCur <> 1 Then
                '复制签名行
                Call copyRangFromOrigin("A6:I6", "A" & desRowCur & ":I" & desRowCur)
                desRowCur = desRowCur + 1
                '插入分页符
                ActiveSheet.Cells(desRowCur, 1).Select
                ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
            End If
            '执行新建表头操作
            desRowCur = actionAndGetRowCur(templateType, rowIndexOrigin, desRowCur)
            '重新赋值日期
            dateOriginCur = origin.Range("B" & rowIndexOrigin).Value
            '赋值当前行收货地区
            demandSideOriginCur = origin.Range("D" & rowIndexOrigin).Value
        Else
            '【收货地区】或【供应商变化】-新建，日期保持
            If demandSideOriginCur <> origin.Range("D" & rowIndexOrigin).Value Or manufacturerNameOriginCur <> origin.Range("C" & rowIndexOrigin).Value Then
                '复制签名行
                Call copyRangFromOrigin("A6:I6", "A" & desRowCur & ":I" & desRowCur)
                desRowCur = desRowCur + 1
                '插入分页符
                ActiveSheet.Cells(desRowCur, 1).Select
                ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
                '执行新建表头操作
                desRowCur = actionAndGetRowCur(templateType, rowIndexOrigin, desRowCur)
                '赋值当前行收货地区
                demandSideOriginCur = origin.Range("D" & rowIndexOrigin).Value
                '赋值当前行供应商
                manufacturerNameOriginCur = origin.Range("C" & rowIndexOrigin).Value
            End If
        End If
        
        '写数据
        desRowCur = writeDataAndGetRowCur(rowIndexOrigin, desRowCur)
    Next
End Sub

writeDataAndGetRowCur

'写入从数据源获取的行数据，并返回目标表当前可操作行行号
Private Function writeDataAndGetRowCur(rowIndexOrigin As Integer, desRowCur As Integer)

    Dim origin, des As Worksheet
    Set origin = Worksheets("发货情况汇总台账（数据源）")
    Set des = Worksheets("result")
    
    '需要从数据源提取的列号
    Dim columnArrayOrigin(1 To 9) As String
    columnArrayOrigin(1) = "A"
    columnArrayOrigin(2) = "C"
    columnArrayOrigin(3) = "E"
    columnArrayOrigin(4) = "F"
    columnArrayOrigin(5) = "G"
    columnArrayOrigin(6) = "H"
    columnArrayOrigin(7) = "K"
    columnArrayOrigin(8) = "L"
    columnArrayOrigin(9) = "M"
    
    '从A开始定义ascii码，每次取值后自增，对应目标表列号
    Dim asciiCode As Integer: asciiCode = 65
    '复制数据行
    Call copyRangFromOrigin("A5:I5", "A" & desRowCur & ":I" & desRowCur)
    '写数据到目标行
    For Each columnOrigin In columnArrayOrigin
        des.Range(Chr(asciiCode) & desRowCur).Value = origin.Range(columnOrigin & rowIndexOrigin).Value
        asciiCode = asciiCode + 1
    Next
    '全局当前可操作行增加
    desRowCur = desRowCur + 1
    
    '返回目标表当前可操作行号
    writeDataAndGetRowCur = desRowCur
End Function

actionAndGetRowCur

'插入模板表头，并返回目标表当前可操作行行号
Private Function actionAndGetRowCur(templateType As Integer, rowIndexOrigin As Integer, desRowCur As Integer)

    Dim origin, des As Worksheet
    Set origin = Worksheets("发货情况汇总台账（数据源）")
    Set des = Worksheets("result")
    
    '复制标题
    Call copyRangFromOrigin("A1:I1", "A" & desRowCur & ":I" & desRowCur)
    If templateType = 1 Then
        des.Range("A" & desRowCur).Value = "日发货情况审批单（模板1）"
    ElseIf templateType = 2 Then
        des.Range("A" & desRowCur).Value = "日发货情况审批单（模板2）"
    End If
    desRowCur = desRowCur + 1
    
    '复制表格信息-收货地区、订单日期
    Call copyRangFromOrigin("A2:I2", "A" & desRowCur & ":I" & desRowCur)
    '填写收货地区
    des.Range("C" & desRowCur).Value = getDemandSideAllName(origin.Range("D" & rowIndexOrigin).Value)
    '填写订单日期
    des.Range("G" & desRowCur).Value = origin.Range("B" & rowIndexOrigin).Value
    desRowCur = desRowCur + 1
    
    '复制表格信息-联系人、联系电话
    Call copyRangFromOrigin("A3:I3", "A" & desRowCur & ":I" & desRowCur)
    '填写联系人
    des.Range("C" & desRowCur).Value = Split(getManufacturerContactName(origin.Range("C" & rowIndexOrigin).Value, origin.Range("D" & rowIndexOrigin).Value), ",")(0)
    '填写联系电话
    des.Range("G" & desRowCur).Value = Split(getManufacturerContactName(origin.Range("C" & rowIndexOrigin).Value, origin.Range("D" & rowIndexOrigin).Value), ",")(1)
    desRowCur = desRowCur + 1
    
    '复制数据项项标题（可根据模板重新定制标题）
    Call copyRangFromOrigin("A4:I4", "A" & desRowCur & ":I" & desRowCur)
    If templateType = 1 Then
        des.Range("E" & desRowCur).Value = "条形码"
        des.Range("G" & desRowCur).Value = "内部流转编码"
    ElseIf templateType = 2 Then
        des.Range("E" & desRowCur).Value = "内部流转编码"
        des.Range("G" & desRowCur).Value = "条形码"
    End If
    desRowCur = desRowCur + 1
    
    '返回目标表当前可操作行号
    actionAndGetRowCur = desRowCur
End Function

copyRangFromOrigin

'将模板区域复制到目标表
Private Sub copyRangFromOrigin(templateRange As String, desRange As String)

    Dim template, des As Worksheet
    Set template = Worksheets("模板")
    Set des = Worksheets("result")
    
    '如果用 template.Range("").Copy des.Range("") 报1004运行时错误
    template.Range(templateRange).Copy
    '设置目标格式
    With des
        ' 同步行高
        .Range(desRange).RowHeight = template.Range(templateRange).RowHeight
        ' 同步内容
        .Range(desRange).Value = template.Range(templateRange).Value
        ' 同步格式和列宽
        .Range(desRange).PasteSpecial Paste:=xlPasteFormats
        .Range(desRange).PasteSpecial Paste:=xlPasteColumnWidths
    End With
End Sub

getManufacturerContactName

'根据供货商名称返回联系人
Private Function getManufacturerContactName(manufacturerName As String, demandSideName As String)
    If InStr(manufacturerName, "XA股份有限公司") > 0 Then
        getManufacturerContactName = "张三,13012345678"
    End If

    If InStr(manufacturerName, "XC股份有限公司") > 0 Then
        getManufacturerContactName = "李四,18912345678"
    End If
    
    If InStr(manufacturerName, "XH股份有限公司") > 0 Then
        getManufacturerContactName = "王五,15512345678"
    End If
    
    If InStr(manufacturerName, "XP股份有限公司") > 0 Then
        getManufacturerContactName = "赵六,18912345678"
    End If
    
    If InStr(manufacturerName, "XX股份有限公司") > 0 Then
        getManufacturerContactName = "沈七,13312345678"
    End If
End Function

getDemandSideAllName

'根据收货地区简称返回全称，对直辖市名称特别处理
Private Function getDemandSideAllName(demandSideName As String)
    If demandSideName = "北京" Then
        getDemandSideAllName = "北京市"
    ElseIf demandSideName = "天津" Then
        getDemandSideAllName = "天津市"
    ElseIf demandSideName = "广西" Then
        getDemandSideAllName = "广西壮族自治区"
    ElseIf demandSideName = "重庆" Then
        getDemandSideAllName = "重庆市"
    ElseIf demandSideName = "上海" Then
        getDemandSideAllName = "上海市"
    ElseIf demandSideName = "宁夏" Then
        getDemandSideAllName = "宁夏回族自治区"
    Else
        getDemandSideAllName = demandSideName & "省"
    End If
End Function