内容提要
自动生成送货单
大家好，我是冷水泡茶，前几天在EXCELHOME论坛上看到一个求助贴，按客户名称、送货单号、送货日期三个条件的唯一性导出送货单：
他的订单明细表是这样的，是一个单独文件“订单总表”：
他的送货单是这样的：
还要求工作表、文件名中都加上客户名称：
这种类型的案例，我们应该分享过好几个，只不过形式各异，跟我们的【文件拆分】有点类似，与【Excel VBA 批量自动生成应收款对账单/应付通知单】也有相同之处，但都不能直接套用。他的本来要求“帮他改改代码“，但是，改代码不一定比自己重写来得省事，还是重新写吧。这两天抽空给弄了一下，分享给大家：
基本思路与过程：
1、在文件“导出用表......"的Sheet1里增加一个命令按钮：
2、增加一个“模板”，固定送货单格式，我这里稍作修改，结构未变：
3、把订单总表数据读入数组。
4、循环数组，把客户、订单号、日期作为关键字添加到字典。
5、把送货单对应数据装入数组，作为字典的Item。
6、循环字典的key，每个key生成一个文件，对应的Item就是送货单的商品明细。
7、把“模板”表复制到一个新建的工作表，写入数据，保存。
VBA代码：
1、在myModule里，Export过程
Sub Export() Dim wb As Workbook Dim ws As Worksheet Dim tbOrder As String Dim savePath As String Dim arr(), arrItem(), arrTem() As String Dim lastRow As Integer, lastCol As Integer Dim dic As Object, dKey As String Dim company As String Dim deliverNo As String Dim deliverDate As String Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim tbFirstLine As Integer Dim tbLastLine As Integer Dim extraLine As Integer Application.DisplayAlerts = False Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") tbOrder = FileSelected If tbOrder = "" Then MsgBox "请正确选择订单总表！" Exit Sub End If savePath = PathSelected If savePath = "" Then If Not wContinue("未选择保存路径，将保存在当前文件夹下！") Then Exit Sub savePath = ThisWorkbook.Path End If Set wb = Workbooks.Open(tbOrder) Set ws = wb.Sheets("收入表") With ws ws.Activate lastRow = .UsedRange.Rows.Count lastCol = .UsedRange.Columns.Count arr = ws.Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Value wb.Close Set wb = Nothing For i = 2 To UBound(arr) If arr(i, 1) <> "" Then dKey = arr(i, Pxy(arr, "客户名称", 2)) & "|" & arr(i, Pxy(arr, "送货单号", 2)) & "|" & arr(i, Pxy(arr, "送货日期", 2)) If dic.exists(dKey) Then arrItem = dic(dKey) k = UBound(arrItem, 2) + 1 ReDim Preserve arrItem(1 To 7, 1 To k) arrItem(1, k) = k arrItem(2, k) = arr(i, Pxy(arr, "订单名称", 2)) arrItem(3, k) = arr(i, Pxy(arr, "单位", 2)) arrItem(4, k) = arr(i, Pxy(arr, "订单数量", 2)) arrItem(5, k) = arr(i, Pxy(arr, "单价", 2)) arrItem(6, k) = arr(i, Pxy(arr, "应收金额", 2)) arrItem(7, k) = arr(i, Pxy(arr, "备注", 2)) Else ReDim Preserve arrItem(1 To 7, 1 To 1) k = 1 arrItem(1, k) = k arrItem(2, k) = arr(i, Pxy(arr, "订单名称", 2)) arrItem(3, k) = arr(i, Pxy(arr, "单位", 2)) arrItem(4, k) = arr(i, Pxy(arr, "订单数量", 2)) arrItem(5, k) = arr(i, Pxy(arr, "单价", 2)) arrItem(6, k) = arr(i, Pxy(arr, "应收金额", 2)) arrItem(7, k) = arr(i, Pxy(arr, "备注", 2)) End If dic(dKey) = arrItem End If Next End With Set wsSource = ThisWorkbook.Sheets("模板") Set cell = wsSource.Columns("A").Find(What:="序号", LookIn:=xlValues, LookAt:=xlPart) tbFirstLine = cell.Row + 1 tbLastLine = tbFirstLine + 1 For Each Key In dic.keys arrItem = dic(Key) arrTem = Split(Key, "|") company = arrTem(0) deliverNo = arrTem(1) deliverDate = Format(CDate(arrTem(2)), "yyyy年mm月dd日") extraLines = UBound(arrItem, 2) - (tbLastLine - tbFirstLine + 1) Set wb = Workbooks.Add wsSource.Copy before:=wb.Sheets(1) Set wsTarget = wb.Sheets(1) wsTarget.Name = company & deliverNo For Each ws In wb.Sheets If ws.Name <> wsTarget.Name Then ws.Delete End If Next With wsTarget .Range("A5") = " 送货单号：" & deliverNo .Range("A6") = " 客户名称：" & company .Range("E5") = "送单日期：" & deliverDate .Range("E6") = "制单日期：" & deliverDate If extraLines > 0 Then .Rows(tbFirstLine + 1 & ":" & tbFirstLine + extraLines).Insert Shift:=xlDown Set Rng = Range(Cells(tbFirstLine + 1, 1), Cells(tbFirstLine + extraLines, 7)) With Rng.Borders .LineStyle = xlContinuous ' 设置为实线 .Weight = xlThin ' 设置线宽 .Item(xlEdgeLeft).LineStyle = xlContinuous .Item(xlEdgeLeft).Weight = xlMedium ' 设置为粗线 .Item(xlEdgeRight).LineStyle = xlContinuous .Item(xlEdgeRight).Weight = xlMedium ' 设置为粗线 End With .Cells(tbFirstLine, 1).Resize(UBound(arrItem, 2), 7) = Application.WorksheetFunction.Transpose(arrItem) .Cells(tbFirstLine + UBound(arrItem, 2), 1) = " 合计人民币金额（大写）：" & RMBDX(.Cells(tbFirstLine + UBound(arrItem, 2), 6)) Else .Cells(tbFirstLine, 1).Resize(UBound(arrItem, 2), 7) = Application.WorksheetFunction.Transpose(arrItem) .Cells(tbLastLine + 1, 1) = " 合计人民币金额（大写）：" & RMBDX(.Cells(tbLastLine + 1, 6)) End If End With wb.SaveAs savePath & "\" & company & deliverNo & "（" & deliverDate & "）.xlsx" wb.Close Next Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "送货单导出完毕！"End Sub
代码解析：
（1）Line1~16，定义一批变量。
（2）line20~29，选择订单总表，把它的完整路径存在tbOrder字符串变量中，选择文件保存路径，存在变量savePath中。
（3）line30~67，打开订单总表，把数据读入数组，再把相关数据装入字典。
（A）line41，dKey，客户名称、送货单号、送货日期，用“|”符号分隔连接起来，这里不要用“/”，因为有日期。
（B）line42~65，循环数组，把数据装入字典Dic。定义一个7行，k列的数组，用来存放送货单的商品明细信息。这个数组跟送货单上的表是一个转置的关系，因为要动态扩展，而数组只能扩展列。
送货单里有一个“序号”，顺便通过k值就给它填上了，也算一个小进步。在前面的【批量自动生成应收款对账单】中，是等数据填好后，再通过循环来添加的。
这里我们还用到一个Pxy自定义函数，根据字段名称来获得数组的下标，不用去数表中字段的位置。
这里把数组赋值给Dic的Item，逻辑是这样的：
（a）我们首先检查dKey是否已存在，如果不存在，我们就定义一个数组arrItem，并把当前数组的i行记录数据存到数组arrItem。
（b）如果已存在dKey，那么它的Item就是一个数组，我们把它赋值给数组arrItem，接着把这个数组扩展一列，填入当前arr数组的i行记录。
（c）最后，不管是新建的、还是扩展的，我们再把这个数组arrItem赋值给Dic的Item。代码第65行，dic(dKey) = arrItem。
（4）line68~71，把模板表赋值给工作表对象wsSource，并计算商品明细表的数据行位置。
（5）line72~114，循环字典的key，把数据写入工作表。
（A）line74~77，把字典的Key分列到数组arrTem，取得“客户名称”、“送货单号”、“送货日期”，把“送货日期”格式化成“yyyy年mm月dd日”的格式。
（B）line78，计算一个extraLine，额外行，模板表中的商品明细是2行，如果当前记录超过2行，则需要插入行。
（C）line79~87，新建工作簿wb，把模板复制到wb，放在最前，赋值给工作表对象wsTarget，并以客户名称+送货单号命名，并把其他工作表删除。
（D）line88~110，把字典Item写入wsTarget。根据需要插入行，并设置单元格画线。对合计数求人民币大写。
（6）line111~112，保存并关闭工作簿。
2、在myModule里，几个自定义函数
Function PathSelected() With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ThisWorkbook.Path .Title = "请选择保存路径" If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框 PathSelected = .SelectedItems(1) Else Exit Function End If End WithEnd FunctionFunction FileSelected() With Application.FileDialog(msoFileDialogFilePicker) .Title = "请选择订单总表文件" .AllowMultiSelect = False '单选择 .Filters.Clear '清除文件过滤器 .Filters.Add "Excel Files", "*.xlsm;*.xlsx;*.xls" '设置两个文件过滤器 .Filters.Add "All Files", "*.*" .InitialFileName = ThisWorkbook.Path & "\.xlsx" If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1或0。 FileSelected = .SelectedItems(1) Else Exit Function End If End WithEnd FunctionFunction wContinue(Msg) As Boolean '确认继续函数 Dim Config As Long Dim a As Long Config = vbYesNo + vbDefaultButton2 + vbQuestion Ans = MsgBox(Msg & Chr(10) & "是(Y)继续?" & Chr(10) _ & "否(N)返回！", Config, "请确认操作！") wContinue = Ans = vbYesEnd FunctionFunction Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)Dim k$, t$ 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 If End Function Public Function RMBDX(m) On Error Resume Next RMBDX = Replace(Application.Text(Round(m + 0.00000001, 2), "[DBnum2]"), ".", "元") RMBDX = IIf(Left(Right(RMBDX, 3), 1) = "元", Left(RMBDX, Len(RMBDX) - 1) _ & "角" & Right(RMBDX, 1) & "分", IIf(Left(Right(RMBDX, 2), 1) = "元", RMBDX _ & "角整", IIf(RMBDX = "零", "", RMBDX & "元整"))) RMBDX = Replace(Replace(Replace(Replace(RMBDX, "零元零角", ""), _ "零元", ""), "零角", "零"), "-", "负")End Function
代码解析：
（1）Line1~11，选择路径函数。
（2）line13~27，选择文件函数。
（3）line29~37，确认继续函数。
（4）line39~74，数组字段定位函数。
（4）line76~84，人民币大写函数。
3、在工作表Sheet1里，导出送货单命令按钮
Private Sub CmdExport_Click() Call ExportEnd Sub
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留个言、分享一下呗！感谢！