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~~~

如果你喜歡它，喜歡它，點選它，發表評論，分享它！感謝您的支援！