根据出库单生成送货单VBA代码

1、在UserForm1里，初始化过程：

DimwbAsWorkbookDimwsAsWorksheetDimshtNameAsStringPrivateSubUserForm_Initialize()saveFolder==saveFolderSub

代码解析：

（1）定义几个公众变量。

（2）把当前文件所在的文件夹作为保存文件夹。可以选择更改。

2、在UserForm1里，几个控件的事件：

PrivateSubCmbSheets_Change()shtName==(shtName)CallSortSheet(ws)SubPrivateSubCmdChooseFile_Click()=FileSelectedfilePath==""ThenSetwb=(filePath)(1).Visible=FalseElseMsgBox"请选择文件！"(1,1)""=(0)shtName==(shtName)CallSortSheet(ws)SubPrivateSubCmdChoosePath_Click()DimpreFolderAsStringDimsaveFolderAsStringpreFolder=(preFolder)ThenpreFolder==PathSelectedIfNotsaveFolder=""=saveFolderElsesaveFolder==saveFolderIfSubPrivateSubCmdExit_Click():=FalseUnloadMeSub

代码解析：

（1）Line1~5，CmbSheets_Change事件，选择不同的工作表。

（2）line7~27，选择出库明细文件，同时把所有工作表添加到cmbSheets的List。

（3）line29~43，选择保存文件夹。

（4）line45~49，退出窗体过程。

PrivateSubCmdOutPut_Click()Dimarr(),arrTem(),iAsIntegerDimlastRowAsIntegerDimlastColAsIntegerDimdicAsObject,dicNumAsObjectDimdKeyAsStringDimfileNameAsStringDimrngAsRangeDimstrItemAsString,==FalseSetdic=CreateObject("")SetdicNum=CreateObject("")saveFolder==.=.=.Range(.Cells(1,1),.Cells(lastRow,lastCol)).ValueWithFori=2ToUBound(arr)dKey=arr(i,9)(dKey)ThenarrTem=dic(dKey)strItem=Join(arrTem,"/")IfInStr(strItem,arr(i,3))=0ThenReDimPreservearrTem(UBound(arrTem)+1)k=UBound(arrTem)arrTem(k)=arr(i,3)dic(dKey)=arrTemIfElseReDimarrTem(0)arrTem(0)=arr(i,3)dic(dKey)==dic(Key)IfUBound(arrTem)0ThenstrMsg=msgKey"|"Join(arrTem,"/")Chr(10)IfNextIfLen(strMsg)0ThenMsgBox"同一出库单有不同地址,请检查！"Chr(10):=FalseFori=2ToUBound(arr)Ifarr(i,1)""ThKey=arr(i,3)(dKey)ThenarrTem=dic(dKey)ReDimPreservearrTem(0To3,0ToUBound(arrTem,2)+1)ElseReDimarrTem(0To3,0To0)Ifk=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)==("送货单")fileName=""arrTem=dic(Key)u=UBound(arrTem,2)Ifu0ThenFori=0ToudKey=arrTem(3,i)dicNum(dKey)=dicNum(dKey)+1=fileNamekey1"-"NextfileName=Left(fileName,Len(fileName)-1)ElsefileName=arrTem(3,0)IffileName=fileName".xlsx"="\"fileNameSetws=("B2")=KeyIfu0ThenRows("6:"6+u-1).Insertshift=("A5").Resize(u+1,4)=(arrTem)Setrng=Range(.Cells(5,3),.Cells(5+u,3))("A5").Resize(1,4)=(arrTem)Setrng=.Cells(5,3)(5+u+1,3).Formula="=sum("")"Fori=5To5+(i,4).Cells(i-1,4)Thenm=(i,4).Cells(i+1,4)Thenn=(.Cells(m,4),.Cells(n,4))."Done!"==TrueShell""""saveFolder"""",vbNormalFocusSub

代码解析：

（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里，“排序”自定义过程：

PrivateSubSortSheet(wsAsWorksheet):=(1,9),_SortOn:=xlSortOnValues,Order:=xlAscing,_DataOption:=====

代码解析：按第9列升序排列。可以把一些属性加入到过程的参数中，这样可以灵活一点。

5、模块myModule里，几个自定义函数和过程：

FunctionPathSelected()(msoFileDialogFolderPicker).InitialFileName==-1Then'FileDialog对象的Show方法显示对话框PathSelected=.SelectedItems(1)ElseExitFunctionIfWithFunctionFunctionFileSelected()(msoFileDialogFilePicker).AllowMultiSelect=False'单选择.'清除文件过滤器."ExcelFiles","*.xlsm;*.xlsx;*.xls"'设置两个文件过滤器."AllFiles","*.*".InitialFileName="\.xlsx"=-1Then'FileDialog对象的Show方法显示对话框，并且返回-1或0。FileSelected=.SelectedItems(1)ElseExitFunctionIfWithFunctionFunctionIsFolderExists(strFolderAsString)AsBooleanDimFSOAsObjectSetFSO=CreateObject("")(strFolder)ThenIsFolderExists=TrueIfFunctionSubShowUserForm()'打开名为UserForm1的用户窗体

代码解析：

（1）Line1~10，自定义函数PathSelected，获取选择的文件夹路径。

（2）line12~25，自定义函数FileSelected，获取选择的文件的完整路径。

（3）line27~33，自定义函数IsFolderExists，判断文件夹是否存在。

（4）Line35~38，启动用户窗体过程，供自定义菜单按钮调用。

6、在ThisWorkbook里，添加自定义菜单按钮：

PrivateSubWorkbook_Open()DimobjB("WorksheetMenuBar")("送货单").DeleteOnErrorGoTo0SetobjPopUp=.(_Type:=msoControlPopup,_before:=.,_temporary:=True)="送货单"SetobjBtn=="生成".OnAction="ShowUserForm".Style==2175WithSubPrivateSubWorkbook_BeforeClose(CancelAsBoolean)("WorksheetMenuBar")("送货单").DeleteOnErrorGoTo0WithSub

代码解析：

（1）Line1~21，文件打开时，添加自定义菜单。

（2）line23~29，文件关闭时，删除自定义菜单。

（3）代码参考微软官网。

~~~~~~~~~~~~