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