基本需求：
- 让用户可以选择多个文件，根据用户选中的工作簿进行合并订单数据，按照预先设计好的订单模板写入数据。
- 对于同一个交易序号下面有多个订单的，需要计算该交易序号下所有订单的总金额、总票数。相同交易序号的只保留1个交易序号，其他为空。
- 遍历每一笔订单是否为黑名单（包括姓名、电话、地址）、外岛地址、边远地址；如果有则在对应行标记对应的颜色：灰色、绿色、蓝色，没有的话标记为正常订单即可。以上名单用户可以自由修改。
- 除了黑名单外，每一笔订单需要生成可供A5打印纸打印的出货单。相同交易序号下多笔订单的要打印在同一张纸上，然后导出pdf文件
- 除了黑名单外，统计每一个店铺的业绩、票数并生成业绩表。
订单原始数据到成品的动画效果：
原始订单数据
需要掌握数组、For循环、字典对象、正则对象、FileDialog对象、函数封装等方法
源码地址（0积分/0C币）：
https://download.csdn.net/download/huaermeier/86514934代码过程：
1、在Sheet1工作表插件1个按钮控件、2个复选框控件，点击鼠标右键点击查看代码：
2、在Sheet1对象编辑代码 ：
3、主要代码模块：
Private Sub CommandButton1_Click() '点击按钮的意思
Dim s1 As Object, s2 As Object
Set s1 = Sheet1'将Sheet1工作表对象赋值给s1
Set s2 = Sheet2'将Sheet2工作表对象赋值给s2
zhucx s1, s2 '调用zhucx过程,传递Sheet1,Sheet2工作表对象
End Sub
'主程序zhucx控制程序执行流程
Sub zhucx(s1 As Object, s2 As Object)
On Error GoTo eror '---------------------------------------执行过程遇到错误时跳转到eror
Application.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\": End
data = 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 = True
MsgBox "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变量表示,因为要跳过表头从第二行开始,所以+2
With 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 = 39
For 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 er
If 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) '金额小计
Else
d(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 If
End If
Next
End With
wb.SaveAs options("phlj") '工作簿另存为,phlj键保存的是拍货表路径
End Sub
'2.创建发货单
Sub createShipmentList(data, options)
Dim wb As Workbook, d As Object
Dim o%, i%, s%, j%, er%
Set wb = Workbooks.Add
Set 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 With
With 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)) Then
er = .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 Then
s = 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 If
End If
Next
End With
wb.SaveAs options("chlj")
End Sub
'3.创建业绩表
Sub createAchievementList(options)
Dim wb As Workbook, d As Object, data
Dim i%, j%, k%, n%, m%
Set wb = Workbooks.Add
Set d = CreateObject("scripting.dictionary")
data = Workbooks(options("phlj")).Sheets(1).[A1].CurrentRegion
With wb.Sheets(1)
options("yj").Copy .[A1]: .[A1].Select
.Columns(1).ColumnWidth = 14
.Columns("B:G").ColumnWidth = 10
.Range("A2" & ":G" & UBound(data)).FillDown
For 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 + 1
m = m + data(i, 20)
Else
j = k + 2: k = k + 1
d(data(i, 5)) = j
.Cells(j, 3) = data(i, 5)
.Cells(j, 4) = 1
.Cells(j, 5) = data(i, 20)
n = n + 1
m = m + data(i, 20)
End If
End If
Next
.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).Merge
End With
wb.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, .xls
If .Show = -1 Then '-----------------------------------判断是否已选中文件
For Each item In .SelectedItems '------------------遍历文件对象
ReDim Preserve arr(i) '------------------------重新声明数组长度并保留原来的数据,目的是在原来的基础上再增加一个位置用于保存文件路径
arr(i) = item '--------------------------------将文件路径写入刚刚增加的位置
i = i + 1 '------------------------------------数组索引+1
Next
getFiles = arr() '---------------------------------返回数组
End If
End 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) = rowData
j = j + 1
Next
wb.Close False '关闭工作簿不做任何提示
Next
getOrderData = data() '返回数组
End Function
'提取配置
Function getOption(s1 As Object, s2 As Object) As Object '这里的s1, s2对应的是Sheet1, Sheet2工作表对象
Dim d As Object, arr
Dim creatime$, kfmc$, hmd$, wd$, by$, pm$ '$声明变量为字符串类型,%声明整数型数字
Dim ph As Range, phlj$, phlk, qfl
Dim ch As Range, chlj$, chlk, chhg
Dim 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 & ",": Next
phlk = 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 Variant
Dim item, arr(), i%
With CreateObject("VBScript.RegExp") '创建正则对象
.Global = True '------------------启用全局
.Pattern = ptn '------------------表达式
For Each item In .Execute(str) '--遍历匹配结果
ReDim Preserve arr(i)
arr(i) = item
i = i + 1
Next
If i > 0 Then regMatch = arr() '--i判断是否匹配,有则返回数组
End With
End Function
'正则表达式替换
Function regReplace(str As String, ptn As String, newStr As String) As String
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = ptn
regReplace = .Replace(str, newStr)
End With
End Function
扫一扫
1966
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
