需求
匯總表部分截取如下：
匯總表部分截取
現需要把其中內容按訂單日期、收貨地區、供應商三個條件拆分成可獨立成頁的審批表，審批表表頭含有公共信息，額外含有供應商聯系人及聯系方式。審批表模板如下：
image.png
最終效果：
image.png
分析
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
