Excel VBA code generates a delivery note based on an outbound order

This article was first published on October 10, 2023 in my eponymous ***Excel Live Learning and Practical Use (VBA Programming Practice), more articles and cases, please search and pay attention!

1. In userform1, the initialization process:

dim wb as workbookdim ws as worksheetdim shtname as stringprivate sub userform_initialize() s**efolder = thisworkbook.path me.txbs**epath = s**efolderend sub

1) Define several public variables.

2) Use the folder where the current file is located as the save folder. You can choose to change it.

2. In userform1, the events of several controls:

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 "Please select a file!" 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) line1 5, cmbsheets change event, select a different worksheet.

2) line7 27, select the outbound detail file, and add all worksheets to the list of cmbsheets.

3) line29 43, select the save folder.

4) line45 49, exit the form process.

3. In userform1, click the "Generate" button on the event:

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 "There are different addresses for the same outbound order, please check!" & 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("Delivery note") 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, define some variables. arrays, dictionaries, etc. 

2) line18, load the data of the outbound schedule into the array arr(). 
3) line20 36, loop array arr, use the order number as the key, the address as the item, and load the distinct data into the dictionary. 
4) line37 46, loop dictionary keys, put item into the array arrtem, if the array element is greater than 1, it means that there is abnormal data, give a hint, exit the process. 
5) line47 48, empty the dictionary dic and array arrtem for later use. 
6) LINE49, I close the outbound list wb and do not save it. 
7) line50 66, loop the array arr, use the address as the key, arrtem as the item to build the dictionary. Among them, ARRTEM is used to store the data required for the delivery note template (date, label number, quantity, outbound order number), because there are multiple records, we use arrays to store them. 
8) line67 113, loop dictionary dic keys, write item data to the delivery note template, save. 
a) line72 84, the name of the construction file. Extract the unique outbound order number from the dictionary dicnum. 
b) line85 88, copy the delivery note template to the new workbook, and save. 
c) line90 98, write the data to the worksheet WS. 
d) line99, set the summary formula for the "Total" row. 
e) line100 108, cycle the 5th row to the last data row of the worksheet, and merge and center the cells with the same outbound order number. 
f) Line109 110, save the workbook wb, close the workbook wb. 
g) line112, before entering the next key loop, empty the dictionary dicnum
9) line118, open the save folder. 
4. In userform1, the "sorting" custom process:
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. In the module mymodule, several custom functions and processes:

function pathselected() with application.filedialog(msofiledialogfolderpicker) .initialfilename = thisworkbook.path if .show = -1 then 'The show method of the filedialog object displays the dialog pathselected = .selecteditems(1) else exit function end if end withend functionfunction fileselected() with application.filedialog(msofiledialogfilepicker) .allowmultiselect = false 'Single Choicefilters.clear 'Clear the file filterfilters.add "excel files", "*.xlsm;*.xlsx;*.xls" 'Set up two file filtersfilters.add "all files", "*.*" .initialfilename = thisworkbook.path & "\.xlsx" if .show = -1 then 'The show method of the filedialog object displays the dialog and returns -1 or 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() 'Open the user form named userform1showend sub

1) line1 10, custom function pathselected, get the selected folder path.

2) line12 25, custom function fileselected, get the full path of the selected file.

3) line27 33, the custom function isfolderexists, to determine whether the folder exists.

4) line35 38, start the user form process for custom menu button calling.

6. In thisworkbook, add a custom menu button:

private sub workbook_open() dim objbtn as commandbarbutton dim objpopup as commandbarpopup with application.commandbars("worksheet menu bar") on error resume next .controls("Delivery note").delete on error goto 0 set objpopup = .controls.add( _type:=msocontrolpopup, _before:=.controls.count, _temporary:=true) end with objpopup.caption = "Delivery note" set objbtn = objpopup.controls.add with objbtn .caption = "Build" .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("Delivery note").delete on error goto 0 end withend sub

1) Line1 21, add a custom menu when the file is opened.

2) line23 29, delete the custom menu when the file is closed.

3) **Refer to Microsoft's official website.

~end~~~

If you like it, like it, click on it, leave a comment, and share it!Thanks for the support!