Excel VBA「案例分享」批量生成送货单

执行摘要

自动生成发货单

大家好，我正在用冷水泡茶，前几天在EXCELHOME论坛上看到一个帮助帖子，我正在根据客户名称、交货单号和交货日期的唯一性导出交货单。

他的订单详细信息如下，是一个单独的“订单摘要”文件：

交货单如下所示：

客户的姓名还需要添加到工作表和文件名中：

我们应该分享一些这种类型的案例，但是形式不同，很类似于我们的【文件分离】，也类似于【ExcelVBA自动批量生成应收应付通知单】，但是不能直接单独使用。他最初的要求是“帮他改代码”。不过，改代码并不一定比自己重写容易，所以他还不如重写一下。这两天我花时间做了这个，分享给大家：

基本思路和流程：

1在“导出表”文件的Sheet1中添加命令按钮：

2添加一个“模板”来修复送货单的格式我这里做了一些修改，但结构保持不变：

3将订单汇总表数据读入数组。

4循环遍历数组，并将客户、订单号和日期作为关键字添加到字典中。

5、将送货单对应的数据加载到数组中，作为字典Item使用。

6循环字典键每个键产生一个文件，对应的Item是交货单的产品详细信息。

7将“模板”表复制到新工作表中，写入数据并保存。

VBA代码：

1在myModule中，Export流程

SubExport()DimwbAsWorkbookDimwsAsWorksheetDimtbOrderAsStringDimsavePathAsStringDimarr()、arrItem()、arrTem()AsStringDimlastRowAsInteger、lastColAsIntegerDimdicAsObjecting、dStrmNotDimDimStringStringAsDateAsStringDimwsSourceAsWorksheetDimws。sTargetAsWorksheetDimtbFirstLineAsIntegerDimtbLastLineAsIntegerDimextraLineAsIntegerApplicationDisplayAlertsFalseApplicationScreenEpdating'FirstObjek'IftbOrderScript''ThenMsgBox'请正确选择订单汇总表！'ExitSubEndIfsavePathSelectedIfsavePath''ThenIfNotwContinue('未选择保存路径，将保存在当前文件夹中！')ThenExitSubsavePathThisWorkbookPathEndIfSetwbWorkbooksOpen(tbOrder)SetwsWbSheetsRowsCountlastColUsedRangeColumnsCountarrwsRange(Cells(1,1),Cells(lastRow,lastCol))ValuewbCloseSetwbNothingFori2ToUBound(arr)Ifarr(i,1)''ThendKeyarr(i,Pxy(arr,'客户名称',2))''arr(i,Pxy(arr,'交货单号',2))''arr(i,Pxy(arr,'交货日期',2))Ifdicexists(dKey)ThenarrItemdic(dKey)kUBound(arrItem,2)1ReDimPreservearrItem(1To7,1Tok)arrItem(1,k)karrItem(2,k)arr(i,Pxy(arr,'订单名称',2))arrItem(3,k)arr(i,Pxy(arr,'单位',2))arrItem(4,k)arr(i,Pxy(arr,'订单数量',2))arrItem(5,k)arr(i,Pxy(arr,'单价',2))arrItem(6,k)arr(i,Pxy(arr,'应收金额',2))arrItem(7,k)arr(i,Pxy(arr,'备注',2))ElseReDimPreservearrItem(1To7,1To1)k1arrItem(1,k)karrItem(2,k)arr(i,Pxy(arr,'订单名称',2))arrItem(3,k)arr(i,Pxy(arr,'单位',2))arrItem(4,k)arr(i,Pxy(arr,'订单数量',2))arrItem(5,k)arr(i,Pxy(arr,'单价',2))arrItem(6,k)arr(i,Pxy(arr,'应收金额',2))arrItem(7,k)arr(i,Pxy(arr,'备注',2))EndIfdic(dKey)arrItemEndIfNextEndWithSetwsSourceThisWorkbookSheet('Template')SetcellwsSourceColumns('A')Find(What:'数字系列',查找范围:xlFixlPartLtLbtLine1ForEachKeyIndi??ckeysarrItemdic(Key)arrTemSplit(Key,'')companyarrTem(0)sendNoarrTem(1)sendDateFormat(CDate(arrTem(2)),'yyyymmmmdddd')extraLineUBound(arrItem,2)-(tbLastLine-tbFirstLineBWorkSetwwbSheet(1)SetTargetwbSheet(1))wsTargetCompanyNameSendNoForEachwsInwbSheetsIfwsNamewsTargetNameThenwsDeleteEndIfNextWithwsTargetRange('A5')'交货编号'CustomerRange'('6CustomerRange':'DeliveryNoRange('E5')'交货日期：'deliverDateRange('E6')'订单发出日期：'deliverDateIfextraLines>0ThenRows(tbFirstLine1':'tbFirstLineextraLines)InsertShift:xlDownSetRngRange(CellsLinells(tb1),1Cells(tbFirstLineextraLines)),7))WithRngBordersLineStylexlContinously'设置为实线WeightxlThin'设置线宽Item(xlEdgeLeft)LineStylexlContinouslyItem(xlEdgeLeft)WeightxlMedium'设置线宽Item(xlEdgeLeft)LineStylexlContinouslyItem(xlEdgeLeft)WeightxlModerate'设置线宽LineStylexlContinously(xlEdgeRight)WeightxlMedium'设置为粗lineEndWithCells(tbFirstLine,1)Resize(UBound(arrItem,2),7)ApplicationWorksheetFunctionTranspose(arrItem)Cells(tbFirstLineUBound(1arrItem,2),)'人民币总计（大写）：'RMBDX(Cells(tbFirstLineUBound(arrItem,2),6))ElseCells(tbFirstLine,1)Resize(UBound(arrItem,2),7)ApplicationWorksheetFunctionTranspose(arrItem)。Cells(tbLastLine1,1)'人民币总金额（大写）：'RMBDX(Cells(tbLastLine1,6))EndIfEndWithwbSaveAssavePath''companydeliverNo'('deliverDate')xlsx'wbCloseNextApplicationCloseNextApplicationDisplayApplicationScredApplicationDisplayApplicationScredApplicationDisplayApplicationScredApplicationDisplayApplicationScredApplicationDisplayApplicationScredAp。LiveryBujang出口完成！'结束子

代码分析：

(1)第1~16行，定义变量组。

(2)第20~29行，选择订单汇总表，将其完整路径保存在tbOrder字符串变量中，选择文件保存路径，并将其保存在savePath变量中。

(3)第30~67行，打开订单汇总表，将数据读入数组，然后将相关数据加载到字典中。

(A)第41行，dKey，客户名称，交货单号，交货日期，用符号“”分隔和连接，这里不要用“/”，因为有日期。

(B)第42~65行，数组循环并将数据加载到Dic字典中。定义一个7行k列的数组，用于存储交货单的产品详细信息。这个数组和发货单上的表格有转置关系，因为它需要动态扩展，而数组只能扩展列。

送货单里有一个“序列号”，顺便通过k的值来填充，这也是一个小小的改进。前面【批量自动生成应收账款报表】中，数据填写完毕后，通过循环添加。

这里我们还使用自定义函数Pxy根据字段名获取数组下标，而不管字段在表中的位置。

这里，给LogicalDicItem的数组如下：

(a)我们首先检查dKey是否已经存在，如果不存在，我们定义一个数组arrItem，并将当前数组的第i行记录的数据存储到数组arrItem中。

(b)如果dKey已经存在，则Item是一个数组，我们将其赋给arrItem数组，然后将数组扩展一列，填充当前arr数组的第i行记录。

(c)最后，无论是新的还是扩展的，我们将数组的arrItem设置为DicItem。代码第65行，dic(dKey)arrItem。

（4）第68~71行，将模板表设置为wsSource工作表对象，并计算商品明细表的数据行位置。

(5)第72~114行，循环字典键，将数据写入工作表中。

(A)第74~77行，将字典键排序到数组arrTem中，得到“客户名称”、“发货单号”、“发货日期”，并将“发货日期”格式化为“年yyyymm月”格式“日”dd。

(B)row78，计数附加行，附加行模板表中的产品详细信息为2行如果当前记录超过2行，则需要插入行。

(C)第79~87行，新建工作簿wb，将模板复制到wb中，放在前面，分配给wsTarget工作表对象，以客户名称、发货单号命名，删除其他工作表。

(D)第88~110行，将Item字典写入wsTarget。根据需要插入线条并设置单元格来绘制线条。总额中使用资本人民币。

(6)第111~112行，保存并关闭工作簿。

2、myModule中，一些自定义函数

FunctionPathSelected()WithApplicationFileDialog(msoFileDialogFolderPicker)InitialFileNameThisWorkbookPathTitle'请选择保存路径'IfShow-1Then'方法显示FileDialog对象显示对话框PathSelectedSelectedWictionEndItemsleSelected()WithApplication。FileDialog(msoFileDialogFilePicker)Title'请选择订单汇总文件'AllowMultiSelectFalse'单选FiltersClear'清除文件过滤器FiltersAdd'ExcelFiles','*xlsm;*xlsx;*xls''设置两个文件过滤器FiltersAdd'AllFiles','**'InitialFileNameThisWorkbookPath'xlsx'IfShow-1Then'FileDialog对象的Show方法显示对话框，并返回-1或0FileSelectedSelectedItems(1)ElseExitFunctionEndIfEndWithEndFunctionFunctionwContinue(Msg)AsBoolean'确认延续函数DimConfigAsLongDimaAsLongConfigvbYesNovbDefaultButton2vbYes'ChrBox1Answer(YM)0)'否(N)返回！',Config,'请确认操作！')wContinueAnsvbYesEndFunctionFunctionPxy(arr(),FieldNameAsString,OptionalarrTypeAsInteger0)Dimk$,t$k0t0SelectCasearrTypeCaseIs0ForiLBound(arr)ToUBound(arr)kk1Ifard1ForLBound(arr,1)ToUBound(arr,1)FieldNameThen1ExitForEndIfNextCaseIs2ForiLBound(arr,2)TOUBONUND(ARR,2)KK1ifarr(1,I)Fieldnamethen1exitForendifnextedSelectift1ThenPxykelSepxy0ndifendFunctionRMBDX(m)umenextrmbdxreplace(applicationtext(rand(m000200001),']')RMBDXIF(Left(Right(RMBDX,3),1)'yuan',Left(RMBDX,Len(RMBDX))-1)'角度'Right(RMBDX,1)'分',IIf(Left(Right(RMBDX,2),1)'元',RMBDX'圆',IIf(RMBDX'零','',RMBDX'元')))RMBDXReplace(替换(替换(替换(RMBDX,'零元零','')),'零元',''),'零角度','零'),'-','负')EndFunction

代码分析：

(1)第1~11行，选择路径功能。

(2)第13~27行，选择文件功能。

(3)第29~37行，确认继续该功能。

(4)第39~74行，数组字段位置函数。

(4)第76~84行，人民币资本函数。

3在Sheet1工作表中，单击导出发货订单命令按钮

PrivateSubCmdExportClick()CallExportEndSub

~~~~~~结束~~~~~~

如果喜欢，请点赞、点击观看、留言、分享！感激的！