本文于2023年10月10日首发于本人同名公众号：Excel活学活用(VBA编程实战），更多文章案例请搜索关注！
内容提要
根据出库单生成送货单VBA代码
1、在UserForm1里，初始化过程：
Dim wb As WorkbookDim ws As WorksheetDim shtName As StringPrivate Sub UserForm_Initialize() saveFolder = ThisWorkbook.Path Me.TxbSavePath = saveFolderEnd Sub
代码解析：
（1）定义几个公众变量。
（2）把当前文件所在的文件夹作为保存文件夹。可以选择更改。
2、在UserForm1里，几个控件的事件：
Private Sub CmbSheets_Change() shtName = Me.CmbSheets Set ws = wb.Sheets(shtName) Call SortSheet(ws)End SubPrivate Sub CmdChooseFile_Click() Me.TxbExcelFile = FileSelected filePath = Me.TxbExcelFile If Not filePath = "" Then Set wb = Workbooks.Open(filePath) wb.Windows(1).Visible = False Else MsgBox "请选择文件！" Exit Sub End If Me.CmbSheets.Clear For Each sht In wb.Worksheets If sht.Cells(1, 1) <> "" Then Me.CmbSheets.AddItem sht.Name End If Next Me.CmbSheets.Text = Me.CmbSheets.List(0) shtName = Me.CmbSheets Set ws = wb.Sheets(shtName) Call SortSheet(ws)End SubPrivate Sub CmdChoosePath_Click() Dim preFolder As String Dim saveFolder As String preFolder = Me.TxbSavePath If Not IsFolderExists(preFolder) Then preFolder = ThisWorkbook.Path End If saveFolder = PathSelected If Not saveFolder = "" Then Me.TxbSavePath = saveFolder Else saveFolder = preFolder Me.TxbSavePath = saveFolder End IfEnd SubPrivate Sub CmdExit_Click() On Error Resume Next wb.Close savechanges:=False Unload MeEnd Sub
代码解析：
（1）Line1~5，CmbSheets_Change事件，选择不同的工作表。
（2）line7~27，选择出库明细文件，同时把所有工作表添加到cmbSheets的List。
（3）line29~43，选择保存文件夹。
（4）line45~49，退出窗体过程。
3、在UserForm1里，“生成”按钮点击事件：
Private Sub CmdOutPut_Click() Dim arr(), arrTem(), i As Integer Dim lastRow As Integer Dim lastCol As Integer Dim dic As Object, dicNum As Object Dim dKey As String Dim fileName As String Dim rng As Range Dim strItem As String, strMsg As String Application.ScreenUpdating = False Application.DisplayAlerts = False Set dic = CreateObject("Scripting.Dictionary") Set dicNum = CreateObject("Scripting.Dictionary") saveFolder = Me.TxbSavePath With ws lastRow = .UsedRange.Rows.Count lastCol = .UsedRange.Columns.Count arr = .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Value End With For i = 2 To UBound(arr) dKey = arr(i, 9) If dic.exists(dKey) Then arrTem = dic(dKey) strItem = Join(arrTem, "/") If InStr(strItem, arr(i, 3)) = 0 Then ReDim Preserve arrTem(UBound(arrTem) + 1) k = UBound(arrTem) arrTem(k) = arr(i, 3) dic(dKey) = arrTem End If Else ReDim arrTem(0) arrTem(0) = arr(i, 3) dic(dKey) = arrTem End If Next For Each Key In dic.keys arrTem = dic(Key) If UBound(arrTem) > 0 Then strMsg = msg & Key & "|" & Join(arrTem, "/") & Chr(10) End If Next If Len(strMsg) > 0 Then MsgBox "同一出库单有不同地址,请检查！" & Chr(10) & strMsg Exit Sub End If dic.RemoveAll Erase arrTem wb.Close savechanges:=False For i = 2 To UBound(arr) If arr(i, 1) <> "" Then dKey = arr(i, 3) If dic.exists(dKey) Then arrTem = dic(dKey) ReDim Preserve arrTem(0 To 3, 0 To UBound(arrTem, 2) + 1) Else ReDim arrTem(0 To 3, 0 To 0) End If k = UBound(arrTem, 2) arrTem(0, k) = arr(i, 1) arrTem(1, k) = arr(i, 5) arrTem(2, k) = arr(i, 7) arrTem(3, k) = arr(i, 9) dic(dKey) = arrTem End If Next For Each Key In dic.keys Set ws = ThisWorkbook.Sheets("送货单") fileName = "" arrTem = dic(Key) u = UBound(arrTem, 2) If u > 0 Then For i = 0 To u dKey = arrTem(3, i) dicNum(dKey) = dicNum(dKey) + 1 Next For Each key1 In dicNum.keys fileName = fileName & key1 & "-" Next fileName = Left(fileName, Len(fileName) - 1) Else fileName = arrTem(3, 0) End If fileName = fileName & ".xlsx" ws.Copy Set wb = ActiveWorkbook wb.SaveAs saveFolder & "\" & fileName Set ws = ActiveSheet With ws .Range("B2") = Key If u > 0 Then Rows("6:" & 6 + u - 1).Insert shift = xlDown .Range("A5").Resize(u + 1, 4) = Application.WorksheetFunction.Transpose(arrTem) Set rng = Range(.Cells(5, 3), .Cells(5 + u, 3)) Else .Range("A5").Resize(1, 4) = Application.WorksheetFunction.Transpose(arrTem) Set rng = .Cells(5, 3) End If .Cells(5 + u + 1, 3).Formula = "=sum(" & rng.Address & ")" For i = 5 To 5 + u If .Cells(i, 4) <> .Cells(i - 1, 4) Then m = i End If If .Cells(i, 4) <> .Cells(i + 1, 4) Then n = i .Range(.Cells(m, 4), .Cells(n, 4)).Merge End If Next wb.Save wb.Close End With dicNum.RemoveAll Next MsgBox "Done!" Unload Me Application.ScreenUpdating = True Application.DisplayAlerts = True Shell "explorer.exe """ & saveFolder & """", vbNormalFocusEnd Sub
代码解析：
（1）Line2~9，定义一些变量。数组、字典等。
（2）line18，把出库明细表数据装入数组arr()。
（3）line20~36，循环数组arr，把订单号作为key，地址作为item，把不重复的数据装入字典。
（4）Line37~46，循环字典keys，把item存入数组arrTem ，如果数组元素大于1，则表示有异常数据，给出提示，退出过程。
（5）line47~48，把字典dic、数组arrTem都清空，以备后用。
（6）line49，把出库明细表wb关闭，不保存。
（7）line50~66，循环数组arr，把地址作为key，arrTem作为item构建字典。其中，arrTem用来存放送货单模板所需数据（日期、面单号、数量、出库单号），因为有多条记录，我们用数组来存放。
（8）line67~113，循环字典dic的keys，把item数据写入送货单模板，保存。
（A）line72~84，构造文件名。通过字典dicNum提取不重复的出库单号。
（B）line85~88，复制送货单模板到新建工作簿，保存。
（C）line90~98，把数据写入工作表ws。
（D）line99，设置“合计”行汇总公式。
（E）line100~108，循环工作表第5行到最后数据行，把出库单号相同的单元格合并居中。
（F）line109~110，保存工作簿wb，关闭工作簿wb。
（G）line112，在进入下一个key循环之前，清空字典dicNum
（9）line118，打开保存文件夹。
4、在UserForm1里，“排序”自定义过程：
Private Sub SortSheet(ws As Worksheet) With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Cells(1, 9), _ SortOn:=xlSortOnValues, Order:=xlAscending, _ DataOption:=xlSortNormal .SetRange ws.UsedRange .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End WithEnd Sub
代码解析：按第9列升序排列。可以把一些属性加入到过程的参数中，这样可以灵活一点。
5、模块myModule里，几个自定义函数和过程：
Function PathSelected() With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ThisWorkbook.Path If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框 PathSelected = .SelectedItems(1) Else Exit Function End If End WithEnd FunctionFunction FileSelected() With Application.FileDialog(msoFileDialogFilePicker) .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 IsFolderExists(strFolder As String) As Boolean Dim FSO As Object Set FSO = CreateObject("Scripting.FileSystemObject") If FSO.folderexists(strFolder) Then IsFolderExists = True End IfEnd FunctionSub ShowUserForm() ' 打开名为UserForm1的用户窗体 UserForm1.ShowEnd Sub
代码解析：
（1）Line1~10，自定义函数PathSelected，获取选择的文件夹路径。
（2）line12~25，自定义函数FileSelected，获取选择的文件的完整路径。
（3）line27~33，自定义函数IsFolderExists，判断文件夹是否存在。
（4）Line35~38，启动用户窗体过程，供自定义菜单按钮调用。
6、在ThisWorkbook里，添加自定义菜单按钮：
Private Sub Workbook_Open() Dim objBtn As CommandBarButton Dim objPopUp As CommandBarPopup With Application.CommandBars("Worksheet Menu Bar") On Error Resume Next .Controls("送货单").Delete On Error GoTo 0 Set objPopUp = .Controls.Add( _ Type:=msoControlPopup, _ before:=.Controls.Count, _ temporary:=True) End With objPopUp.Caption = "&送货单" Set objBtn = objPopUp.Controls.Add With objBtn .Caption = "生成" .OnAction = "ShowUserForm" .Style = msoButtonCaption .FaceId = 2175 End WithEnd SubPrivate Sub Workbook_BeforeClose(Cancel As Boolean) With Application.CommandBars("Worksheet Menu Bar") On Error Resume Next .Controls("送货单").Delete On Error GoTo 0 End WithEnd Sub
代码解析：
（1）Line1~21，文件打开时，添加自定义菜单。
（2）line23~29，文件关闭时，删除自定义菜单。
（3）代码参考微软官网。
~~~~~~End~~~~~~
喜欢就点个赞、点在看、留言评论、分享一下呗！感谢支持！