Excel VBA 代码根据出库订单生成交货单

本文首发于2024年10月10日，收录于我的同名***Excel Live Learning and Practical Use （VBA Programming Practice），更多文章和案例，请搜索关注！

1. 在 userform1 中，初始化过程：

dim wb as workbookdim ws as worksheetdim shtname as stringprivate sub userform_initialize() s**efolder = thisworkbook.path me.txbs**epath = s**efolderend 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 s**efolder as string prefolder = me.txbs**epath if not isfolderexists(prefolder) then prefolder = thisworkbook.path end if s**efolder = pathselected if not s**efolder = "" then me.txbs**epath = s**efolder else s**efolder = prefolder me.txbs**epath = s**efolder end ifend subprivate sub cmdexit_click() on error resume next wb.close s**echanges:=false unload meend sub

1）第1行5，CMBSHEETS更改事件，选择不同的工作表。

2）第7行27，选择出站详细信息文件，然后将所有工作表添加到CMBTones列表中。

3） 第 29 行 43，选择保存文件夹。

4）45 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") s**efolder = me.txbs**epath 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 s**echanges:=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.s**eas s**efolder & "\" & 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） 1）line2 9，定义一些变量。数组、字典等 

2） 第 18 行，将出站调度的数据加载到数组 arr（） 中。
3）第20行36，循环数组arr，以订单号为键，以地址为项，将非重复数据加载到字典中。
4）第37行46，循环字典键，将项目放入数组arrtem中，如果数组元素大于1，则表示有异常数据，给出提示，退出进程。
5） 第 47 行 48，清空字典 dic 和数组 arrtem 以备后用。
6）LINE49，我关闭了出站列表wb，不保存它。
7）50 66行，循环数组arr，以地址为键，arrtem为项构建字典。其中，ARRTEM 用于存储交货单模板所需的数据（日期、标签号、数量、出库订单号），因为存在多条记录，我们使用数组来存储它们。 
8）67 113行，循环字典DIC键，将项目数据写入交货单模板，保存。
a） 第 72 行 84，构造文件的名称。从字典 dicnum 中提取唯一的出站订单号。 
b） 第 85 88 行，将交货单模板复制到新工作簿，然后保存。
c） 第 90 行 98，将数据写入工作表 WS。
d） 第 99 行，设置“总计”行的汇总公式。
e） 第 100 行 108，将第 5 行循环到工作表的最后一行数据行，并将具有相同出站订单号的单元格合并并居中。
f） 第 109 行 110，保存工作簿 wb，关闭工作簿 wb。
g） 第 112 行，在进入下一个键循环之前，清空字典 dicnum
9） 第 118 行，打开保存文件夹。
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

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 的用户窗体showend sub

1）line1 10，自定义函数pathselected，获取所选文件夹路径。

2）第12行25，自定义函数fileselected，获取所选文件的完整路径。

3）第27 33行，自定义函数isfolderexists，判断文件夹是否存在。

4） 第 35 行 38，启动自定义菜单按钮调用的用户表单进程。

6. 在此工作簿中，添加自定义菜单按钮：

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）第23行29，文件关闭时删除自定义菜单。

3）**请参阅Microsoft的官方网站。

~end~~~

如果你喜欢它，喜欢它，点击它，发表评论，分享它！感谢您的支持！