基本需求：

让用户可以选择多个文件，根据用户选中的工作簿进行合并订单数据，按照预先设计好的订单模板写入数据。
对于同一个交易序号下面有多个订单的，需要计算该交易序号下所有订单的总金额、总票数。相同交易序号的只保留1个交易序号，其他为空。
遍历每一笔订单是否为黑名单（包括姓名、电话、地址）、外岛地址、边远地址；如果有则在对应行标记对应的颜色：灰色、绿色、蓝色，没有的话标记为正常订单即可。以上名单用户可以自由修改。
除了黑名单外，每一笔订单需要生成可供A5打印纸打印的出货单。相同交易序号下多笔订单的要打印在同一张纸上，然后导出pdf文件
除了黑名单外，统计每一个店铺的业绩、票数并生成业绩表。

订单原始数据到成品的动画效果：

原始订单数据

需要掌握数组、For循环、字典对象、正则对象、FileDialog对象、函数封装等方法

源码地址（0积分/0C币）：

ExcelVBA自动统计业绩+处理订单表格原始数据+生成打印发货单模板-VB文档类资源-CSDN下载用于批量处理大量的订单数据,适合跟单人员使用更多下载资源、学习资料请访问CSDN下载频道.https://download.csdn.net/download/huaermeier/86514934

代码过程：

1、在Sheet1工作表插件1个按钮控件、2个复选框控件，点击鼠标右键点击查看代码：

2、在Sheet1对象编辑代码：

3、主要代码模块：

Private Sub CommandButton1_Click() '点击按钮的意思Dim s1 As Object, s2 As ObjectSet s1 = Sheet1'将Sheet1工作表对象赋值给s1Set s2 = Sheet2'将Sheet2工作表对象赋值给s2zhucx s1, s2 '调用zhucx过程,传递Sheet1,Sheet2工作表对象
End Sub'主程序zhucx控制程序执行流程
Sub zhucx(s1 As Object, s2 As Object)
On Error GoTo eror '---------------------------------------执行过程遇到错误时跳转到erorApplication.ScreenUpdating = False '-------------------关闭屏幕刷新Dim pth$, pths, data, options As Object'判断B3是否匹配.xls,是则利用regMatch自定义函数正则匹配文件路径赋值给pth,否则pth="C:\Users\Administrator\Desktop\"If InStr(s1.[B3], ".xls") > 0 Then pth = regMatch(s1.[B3], ".+\\")(0) Else pth = "C:\Users\Administrator\Desktop\"'利用前面封装好的getFiles函数打开文件对话框,如果返回的是数组则B3等于用户所选的文件路径; 否则弹出提示并直接利用End方法结束程序pths = getFiles(pth)If IsArray(pths) Then s1.[B3] = Join(pths, Chr(10)) Else MsgBox "No File Selected": s1.[B3] = "C:\Users\Administrator\Desktop\": Enddata = getOrderData(pths) '----------------------------利用前面封装好的getOrderData函数提取订单数据Set options = getOption(s1, s2) '----------------------利用前面封装好的getOption函数提取配置,这里返回的是由字典对象保存的数据,字典的键全部用拼音首字母代替'提取到订单数据和配置后,下发任务给各个子过程执行createAuctionList data, options '----------------------向createAuctionList过程传递data, options参数1.创建拍货表If s1.CheckBox1 Then createShipmentList data, options '如果Sheet1出货单复选框选中,则2.创建出货单If s1.CheckBox2 Then createAchievementList options '---如果Sheet1业绩统计复选框选中,则3.创建业绩表Exit Sub
eror: '错误处理Application.ScreenUpdating = TrueMsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
End Sub'1.创建拍货表
Sub createAuctionList(data, options) '------------data接收订单数据,options接收配置Dim d As Object, k% '-------------------------d声明为对象; wb为工作簿; k%表示声明变量为整数型数字的缩写,另一种写法是k As Integer, er%, i%同理Dim wb As Workbook, er%, i%Set d = CreateObject("scripting.dictionary") '创建字典对象Set wb = Workbooks.Add '----------------------新建工作簿er = UBound(data) + 2 '-----------------------data传入的数据是数组,数组索引由0开始,这里要对应到工作表行号用er变量表示,因为要跳过表头从第二行开始,所以+2With wb.Sheets(1)'表头样式.Rows(1).RowHeight = 36 '设置表头行高'表格样式.Range("A1" & ":AM" & er).WrapText = True                '自动换行.Range("A1" & ":AM" & er).HorizontalAlignment = xlCenter '字体水平居中.Range("A1" & ":AM" & er).Borders.LineStyle = 1          '添加边框线.Rows("2:" & er).RowHeight = 39For i = 0 To UBound(options("phlk")): .Columns(i + 1).ColumnWidth = options("phlk")(i): Next '设置列宽,这里与er变量同理,列号从1开始,所以+1; options("phlk")访问的是字典的键,字典的键这里全部用拼音首字母代替,它的值是数组'填充表头数据options("ph").Copy .[A1]: .[A1].Select  '将ph复制到单元格A1.[A2:AC2].ClearContents                 '清除A2:AC2区域的内容,但保留格式.Range("A2" & ":AM" & er).FillDown      '相当于填充快捷键Ctrl + D'填充表体数据.Range("A2" & ":A" & er) = options("qfl")(0)         '区分类默认为正常.Range("C2" & ":C" & er) = options("kfmc")           '客服名字.Range("D2" & ":D" & er) = options("ph").Cells(2, 4) '平台For i = 2 To erIf d.Exists(data(i - 2)(11)) Then 'Exists是字典对象方法,判断键是否存在k = d(data(i - 2)(11))        'k获取保存在字典的行号.Cells(k, 19) = .Cells(k, 19) + data(i - 2)(1) '数量.Cells(k, 20) = .Cells(k, 20) + data(i - 2)(2) + data(i - 2)(3) '订单金额.Cells(i, 2) = data(i - 2)(9)     '转单日期.Cells(i, 5) = data(i - 2)(15)    '店名.Cells(i, 6) = data(i - 2)(12)    '物流设定'.Cells(i, 12) = data(i - 2)(11)   '交易序号.Cells(i, 13) = data(i - 2)(4)    '收件人.Cells(i, 14) = data(i - 2)(8)    '地址.Cells(i, 15) = data(i - 2)(7)    '行动电话.Cells(i, 16) = data(i - 2)(6)    '电话2'.Cells(i, 19) = data(i - 2)(1)    '数量'.Cells(i, 20) = data(i - 2)(2) + data(j, 3) '订单金额.Cells(i, 21) = data(i - 2)(13)   '购物车备注.Cells(i, 22) = data(i - 2)(1)    '数量.Cells(i, 23) = data(i - 2)(0)    '规格.Cells(i, 24) = data(i - 2)(5)    '订单编号.Cells(i, 25) = data(i - 2)(14)   '商品名称.Cells(i, 26) = "https://tw.mall.yahoo.com/item/" & data(i - 2)(10) '商品编号.Cells(i, 27) = data(i - 2)(2)    '超赠点.Cells(i, 28) = data(i - 2)(3)    '金额小计Elsed(data(i - 2)(11)) = i            '键在字典中不存在则记录行号.Cells(i, 2) = data(i - 2)(9)     '转单日期.Cells(i, 5) = data(i - 2)(15)    '店名.Cells(i, 6) = data(i - 2)(12)    '物流设定.Cells(i, 12) = data(i - 2)(11)   '交易序号.Cells(i, 13) = data(i - 2)(4)    '收件人.Cells(i, 14) = data(i - 2)(8)    '地址.Cells(i, 15) = data(i - 2)(7)    '行动电话.Cells(i, 16) = data(i - 2)(6)    '电话2.Cells(i, 19) = data(i - 2)(1)    '数量.Cells(i, 20) = data(i - 2)(2) + data(i - 2)(3) '订单金额.Cells(i, 21) = data(i - 2)(13)   '购物车备注.Cells(i, 22) = data(i - 2)(1)    '数量.Cells(i, 23) = data(i - 2)(0)    '规格.Cells(i, 24) = data(i - 2)(5)    '订单编号.Cells(i, 25) = data(i - 2)(14)   '商品名称.Cells(i, 26) = "https://tw.mall.yahoo.com/item/" & data(i - 2)(10) '商品编号.Cells(i, 27) = data(i - 2)(2)    '超赠点.Cells(i, 28) = data(i - 2)(3)    '金额小计'边远地区,IsArray判断是否为数组If IsArray(regMatch((data(i - 2)(8)), (options("by")))) Then.Range("A" & i & ":AM" & i).Interior.ColorIndex = 33 '填充颜色.Range("A" & i) = options("qfl")(3)End If'外岛地区If IsArray(regMatch((data(i - 2)(8)), (options("wd")))) Then.Range("A" & i & ":AM" & i).Interior.ColorIndex = 43.Range("A" & i) = options("qfl")(2)End If'黑名单If IsArray(regMatch((data(i - 2)(4) & data(i - 2)(7) & data(i - 2)(8)), (options("hmd")))) Then.Range("A" & i & ":AM" & i).Interior.ColorIndex = 15.Range("A" & i) = options("qfl")(1)End IfEnd IfNextEnd Withwb.SaveAs options("phlj") '工作簿另存为,phlj键保存的是拍货表路径End Sub'2.创建发货单
Sub createShipmentList(data, options)Dim wb As Workbook, d As ObjectDim o%, i%, s%, j%, er%Set wb = Workbooks.AddSet d = CreateObject("scripting.dictionary")With wb.Sheets(1).PageSetup.Orientation = xlLandscape   '横向.PaperSize = xlPaperA5       'A5.LeftMargin = 14.173228      '左边距.RightMargin = 14.173228     '右边距.TopMargin = 14.173228       '上边距.BottomMargin = 14.173228    '下边距.HeaderMargin = 0            '页眉边距.FooterMargin = 0            '页脚边距.CenterHorizontally = True   '水平居中.CenterVertically = True     '垂直居中ActiveWindow.View = xlPageLayoutView '页面布局End WithWith wb.Sheets(1)For o = 0 To UBound(options("chlk")): .Columns(o + 1).ColumnWidth = options("chlk")(o): Next '设置列宽For i = 0 To UBound(data)If d.Exists(data(i)(11)) Thener = .Cells(.Rows.Count, 1).End(xlUp).Row + 1.Cells(d(data(i)(11)) + 3, 6) = .Cells(d(data(i)(11)) + 3, 6) + data(i)(2) + data(i)(3) '订单总金额.Cells(er, 1) = data(i)(0)  '规格颜色.Cells(er, 2) = data(i)(1)  '数量.Cells(er, 3) = data(i)(5)  '订单编号.Cells(er, 4) = "https://tw.mall.yahoo.com/item/" & data(i)(10) '产品编号.Cells(er, 5) = data(i)(14) '商品名称.Cells(er, 6) = data(i)(2)  '超赠点.Cells(er, 7) = data(i)(3)  '金额小计Else'跳过黑名单If IsArray(regMatch((data(i)(4) & data(i)(7) & data(i)(8)), (options("hmd")))) = False Thens = j * 13 + 1: j = j + 1   '新建出货单对应的行号d(data(i)(11)) = s      '将行号记录到字典options("ch").Copy .Range("A" & s)  '将出货单模板复制到s行For o = 0 To UBound(options("chhg")): .Rows(o + s).RowHeight = options("chhg")(o): Next '设置出货单模板行高'写入数据.Cells(s + 1, 1) = data(i)(9)      '转单日.Cells(s + 1, 2) = options("kfmc") '客服名称.Cells(s + 1, 3) = options("ph").Cells(2, 4) '平台.Cells(s + 1, 4) = data(i)(12)     '物流设定.Cells(s + 1, 5) = data(i)(15)     '店名.Cells(s + 3, 1) = data(i)(11)     '交易序号.Cells(s + 3, 2) = data(i)(4)      '收件人.Cells(s + 3, 3) = data(i)(7)      '电话.Cells(s + 3, 4) = data(i)(6)      '电话2.Cells(s + 3, 5) = data(i)(8)      '地址.Cells(s + 3, 6) = data(i)(2) + data(i)(3) '订单总金额.Cells(s + 3, 7) = data(i)(13)     '购物车备注.Cells(s + 5, 1) = data(i)(0)      '规格颜色.Cells(s + 5, 2) = data(i)(1)      '数量.Cells(s + 5, 3) = data(i)(5)      '订单编号.Cells(s + 5, 4) = "https://tw.mall.yahoo.com/item/" & data(i)(10) '产品编号.Cells(s + 5, 5) = data(i)(14)     '商品名称.Cells(s + 5, 6) = data(i)(2)      '超赠点.Cells(s + 5, 7) = data(i)(3)      '金额小计End IfEnd IfNextEnd Withwb.SaveAs options("chlj")End Sub'3.创建业绩表
Sub createAchievementList(options)Dim wb As Workbook, d As Object, dataDim i%, j%, k%, n%, m%Set wb = Workbooks.AddSet d = CreateObject("scripting.dictionary")data = Workbooks(options("phlj")).Sheets(1).[A1].CurrentRegionWith wb.Sheets(1)options("yj").Copy .[A1]: .[A1].Select.Columns(1).ColumnWidth = 14.Columns("B:G").ColumnWidth = 10.Range("A2" & ":G" & UBound(data)).FillDownFor i = 2 To UBound(data)If data(i, 1) <> options("qfl")(1) And data(i, 12) <> "" Then '过滤黑名单和空交易序号If d.Exists(data(i, 5)) Then.Cells(d(data(i, 5)), 4) = .Cells(d(data(i, 5)), 4) + 1.Cells(d(data(i, 5)), 5) = .Cells(d(data(i, 5)), 5) + data(i, 20)n = n + 1m = m + data(i, 20)Elsej = k + 2: k = k + 1d(data(i, 5)) = j.Cells(j, 3) = data(i, 5).Cells(j, 4) = 1.Cells(j, 5) = data(i, 20)n = n + 1m = m + data(i, 20)End IfEnd IfNext.Rows(j + 1 & ":" & UBound(data)).Delete.Rows("2:" & j).RowHeight = 30.[A2] = Format(Now(), "yyyy-m-d"): .Range("A2" & ":A" & j).Merge.[B2] = options("kfmc"): .Range("B2" & ":B" & j).Merge.[F2] = n: .Range("F2" & ":F" & j).Merge.[G2] = m: .Range("G2" & ":G" & j).MergeEnd Withwb.SaveAs options("yjlj")End Sub'功能模块
'提取订单文件路径
Function getFiles(pth As String) As Variant '------------------pth参数接收文件夹路径,该函数返回一个用数组保存的文件路径Dim obj As FileDialog, item, arr(), i%Set obj = Application.FileDialog(msoFileDialogFilePicker) '创建文件选择对话框对象With obj.Title = "选择订单,可多选" '----------------------------对话框标题.AllowMultiSelect = True '-----------------------------启用多选.InitialFileName = pth '-------------------------------设置默认文件路径.Filters.Clear '---------------------------------------清空文件筛选器.Filters.Add "Excel Files", "*.xlsx; *.xls" '----------文件筛选器添加后缀名.xlsx, .xlsIf .Show = -1 Then '-----------------------------------判断是否已选中文件For Each item In .SelectedItems '------------------遍历文件对象ReDim Preserve arr(i) '------------------------重新声明数组长度并保留原来的数据,目的是在原来的基础上再增加一个位置用于保存文件路径arr(i) = item '--------------------------------将文件路径写入刚刚增加的位置i = i + 1 '------------------------------------数组索引+1NextgetFiles = arr() '---------------------------------返回数组End IfEnd With
End Function'提取订单数据
Function getOrderData(pth As Variant) As Variant '-------------pth参数接收由数组保存的文件路径Dim wb As Workbook, flle, metaData, rowData, data(), i%, j%For Each flle In pth '-------------------------------------遍历文件路径Set wb = Workbooks.Open(flle) '------------------------根据文件路径打开工作簿,并将该作簿对象传给wb变量metaData = wb.Sheets(1).[A1].CurrentRegion '-----------将Sheet1工作表数据写入metaData变量For i = 2 To UBound(metaData) '------------------------遍历数据,i=2是为了跳过表头,从第二行开始rowData = Application.Index(metaData, i) '---------按行转换为一维数组ReDim Preserve rowData(UBound(rowData)) '----------重新声明rowData数组长度rowData(UBound(rowData)) = regReplace(wb.Name, "(.xlsx)|(.xls)|\((.*?)\)", "") '提取工作簿名称,去掉后缀名.xlsx, .xls, (除换行符外的任意字符); regReplace是自定义函数ReDim Preserve data(j)data(j) = rowDataj = j + 1Nextwb.Close False '关闭工作簿不做任何提示NextgetOrderData = data() '返回数组
End Function'提取配置
Function getOption(s1 As Object, s2 As Object) As Object '这里的s1, s2对应的是Sheet1, Sheet2工作表对象Dim d As Object, arrDim creatime$, kfmc$, hmd$, wd$, by$, pm$ '$声明变量为字符串类型,%声明整数型数字Dim ph As Range, phlj$, phlk, qflDim ch As Range, chlj$, chlk, chhgDim yj As Range, yjlj$Set d = CreateObject("scripting.dictionary") '创建字典对象creatime = Now() '当前时间kfmc = s1.[B2] '客服名字arr = s1.Range("A8" & ":A" & s1.Cells(s1.Rows.Count, 1).End(xlUp).Row) 'Cells(s1.Rows.Count, 1).End(xlUp).Row定位A列有数据的最后一行arr = Application.Transpose(Application.Index(arr, , 1)) '按列转换为一维数组hmd = Join(arr, "|") '黑名单,利用join方法拼接数组,目的是为了使用正则表达式匹配黑名单arr = s1.Range("B8" & ":B" & s1.Cells(s1.Rows.Count, 2).End(xlUp).Row)arr = Application.Transpose(Application.Index(arr, , 1))wd = Join(arr, "|") '外岛地区arr = s1.Range("C8" & ":C" & s1.Cells(s1.Rows.Count, 3).End(xlUp).Row)arr = Application.Transpose(Application.Index(arr, , 1))by = Join(arr, "|") '边远地区arr = s1.Range("D8" & ":D" & s1.Cells(s1.Rows.Count, 4).End(xlUp).Row)arr = Application.Transpose(Application.Index(arr, , 1))pm = Join(arr, "|") '品名Set ph = s2.[A1:AM2] '拍货表模板phlj = ThisWorkbook.Path & "\" & Format(creatime, "yyyy-mm-dd") & " " & kfmc & " " & s2.[AN1] '拍货表路径s2.[AN2] = phlj '拍货表路径写入Sheet2.[AN2]qfl = Split(s2.[A2], ",") '拍货表区分类For Each arr In s2.[A3:AM3]: phlk = phlk & arr & ",": Nextphlk = Split(Left(phlk, Len(phlk) - 1), ",") '拍货表模板列宽Set ch = s2.[A7:I19] '出货单模板chlj = ThisWorkbook.Path & "\" & Format(creatime, "yyyy-mm-dd") & " " & kfmc & " " & s2.[AO1] '出货单路径chlk = Array(14, 9, 14, 10, 15, 9, 8.5, 8.5, 8.5) '出货单模板列宽chhg = Array(22, 36, 22, 36, 22, 30, 30, 30, 30, 30, 30, 30, 30) '出货单模板行高Set yj = s2.[A24:G25] '业绩表模板yjlj = ThisWorkbook.Path & "\" & Format(creatime, "yyyy-mm-dd") & " " & kfmc & " " & s2.[AP1] '业绩表模板路径'将名单添加到字典d.Add "creatime", creatime '创建时间d.Add "kfmc", kfmc         '客服名称d.Add "hmd", hmd           '黑名单d.Add "wd", wd             '外岛地区d.Add "by", by             '边远地区d.Add "pm", pm             '品名d.Add "ph", ph             '拍货表模板d.Add "phlj", phlj         '拍货表模板路径d.Add "qfl", qfl           '拍货表模板区分类d.Add "phlk", phlk         '拍货表模板列宽d.Add "ch", ch             '出货单模板d.Add "chlj", chlj         '出货单模板路径d.Add "chlk", chlk         '出货单模板列宽d.Add "chhg", chhg         '出货单模板行高d.Add "yj", yj             '业绩表模板d.Add "yjlj", yjlj         '业绩表模板路径Set getOption = d          '对象需要用set方法
End Function'正则表达式匹配
Function regMatch(str As String, ptn As String) As VariantDim item, arr(), i%With CreateObject("VBScript.RegExp") '创建正则对象.Global = True '------------------启用全局.Pattern = ptn '------------------表达式For Each item In .Execute(str) '--遍历匹配结果ReDim Preserve arr(i)arr(i) = itemi = i + 1NextIf i > 0 Then regMatch = arr() '--i判断是否匹配,有则返回数组End With
End Function'正则表达式替换
Function regReplace(str As String, ptn As String, newStr As String) As StringWith CreateObject("VBScript.RegExp").Global = True.Pattern = ptnregReplace = .Replace(str, newStr)End With
End Function

Excel VBA自动化办公：选择Excel文件合并订单数据生成订单汇总表、生成发货单并导出pdf文件、自动统计业绩生成业绩表相关推荐

怎么把单个的pdf文件合并在一起？怎么把几个单独的pdf文件合并为一个？
怎么把单个的pdf文件合并在一起?怎么把几个单独的pdf文件合并为一个?有时候我们需要把多个pdf合并成一个pdf,但是还有些小伙伴不知道pdf合并成一个pdf软件哪个好?有时候我们需要把多个pdf合 ...
Swagger2生成在线接口文档并导出pdf文件
文章目录一,配置 1,pom依赖 2,通用配置二,注解三,主题 1,默认主题效果 2,添加依赖 3,添加配置 4,启动看效果四,token验证方法1,所有接口上添加方法2,全局统一添加五 ...
python办公自动化excel_简直出神入化，教你用Python控制Excel实现自动化办公
1.安装简直出神入化,教你用Python控制Excel实现自动化办公 2.操作一个简单的Excel文档操作注释及代码: 简直出神入化,教你用Python控制Excel实现自动化办公操作完成后,数 ...
python做excel自动化可视化-简直出神入化，教你用Python控制Excel实现自动化办公...
1.安装简直出神入化,教你用Python控制Excel实现自动化办公 2.操作一个简单的Excel文档操作注释及代码: 简直出神入化,教你用Python控制Excel实现自动化办公操作完成后,数 ...
python excel 自动化-简直出神入化，教你用Python控制Excel实现自动化办公
1.安装简直出神入化,教你用Python控制Excel实现自动化办公 2.操作一个简单的Excel文档操作注释及代码: 简直出神入化,教你用Python控制Excel实现自动化办公操作完成后,数 ...
python自动化办公-简直出神入化，教你用Python控制Excel实现自动化办公
1.安装简直出神入化,教你用Python控制Excel实现自动化办公 2.操作一个简单的Excel文档操作注释及代码: 简直出神入化,教你用Python控制Excel实现自动化办公操作完成后,数 ...
Python骚操作：Python控制Excel实现自动化办公！
Python骚操作:Python控制Excel实现自动化办公! 1.安装 Python骚操作:Python控制Excel实现自动化办公! 2.操作一个简单的Excel文档操作注释及代码: Pytho ...
python处理Excel实现自动化办公教学（数据筛选、公式操作、单元格拆分合并、冻结窗口、图表绘制等）【三】
相关文章: python处理Excel实现自动化办公教学(含实战)[一] python处理Excel实现自动化办公教学(含实战)[二] python处理Excel实现自动化办公教学(数据筛选.公式操作 ...
自动化办公之excel教程（1）：工作薄，工作表，单元格基本操作
一.工作薄的基本操作 1.工作薄表的保护在审阅里有保护工作表,保护工作薄等.点击输入密码. 其他人没有密码则无法对表格进行修改.表格只能看,不能修改. 2.工作薄的加密第一步点击文件另存为. 会 ...

Excel VBA自动化办公：选择Excel文件合并订单数据生成订单汇总表、生成发货单并导出pdf文件、自动统计业绩生成业绩表

基本需求：

订单原始数据到成品的动画效果：

代码过程：

Excel VBA自动化办公：选择Excel文件合并订单数据生成订单汇总表、生成发货单并导出pdf文件、自动统计业绩生成业绩表相关推荐

最新文章

热门文章