用字典+ADO查询实现计费表格查询

zhaogang1960 · 发表于 2014-3-7 00:04

本帖最后由 zhaogang1960 于 2014-3-7 15:46 编辑

用字典+ADO查询实现计费表格查询

今天遇到一个根据邮寄地点、邮件分量查表计费的题目，觉得挺有参考价值，现专门发帖分享。原帖网址：

运费计算

http://club.excelhome.net/thread-1100432-1-1.html

要求：

A列为每个不重复订单的重量合计值，每个订单的运费计算需判断的因素有：库房编码、快递公司、目的省、目的市、重量，而运算因素有：首重、首重收费、续重1KG收费、上门服务费，订单运费=首重收费+续重1KG收费*（重量-首重）+上门服务费。如何得出每个订单的运费。见下图。

本题目有5个条件：
目的省目的市快递公司库房编码订单重量

前4个用来定位行号，是一对多的关系，即相同的条件对应着订单表的多行，有两种情况
不考虑目的市，考虑目的市——通过对应的运费标准表中是否是省内所有来决定用哪一个，且考虑目的市优先
SQL语句用左外连接实现先不考虑订单重量，而把所有可能的匹配罗列出来
在众多符合前4个条件的数据中，再用订单重量来判断是否符合条件——If Application.Evaluate(arr(0, i) & arr(8, i)) Then
优先考虑目的市，即有目的市时直接写数据，没有目的市时要先判断改行数据是否已经有数据了，如果有就不再覆盖了。代码如下：

Sub 计算订单运费()
Dim cnn, SQL$, a, arr, brr(), i&, j&, s$, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary") '创建字典对象，以储存库房编码、快递公司、目的省字符串确定的行号
Set ds = CreateObject("scripting.dictionary") '创建字典对象，以储存库房编码、快递公司、目的省、目的市字符串确定的行号
arr = [a1].CurrentRegion '“订单”工作表数据写入数组
ReDim brr(2 To UBound(arr), 1 To 1) '重新定义数组，行数等于数据行数
For i = 2 To UBound(arr)
s = arr(i, 8) & arr(i, 7) & arr(i, 5) & arr(i, 1) '库房编码、快递公司、目的省字符串
d(s) = d(s) & "," & i '库房编码、快递公司、目的省添加到字典键值，行号添加到字典条目
s = arr(i, 8) & arr(i, 7) & arr(i, 5) & arr(i, 1) & arr(i, 6) '库房编码、快递公司、目的省、目的市字符串
ds(s) = ds(s) & "," & i '库房编码、快递公司、目的省、目的市添加到字典键值，行号添加到字典条目
Next
Set cnn = CreateObject("adodb.connection") '创建ADO连接对象
cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ActiveWorkbook.FullName '连接数据库
'SQL语句用左外连接实现先不考虑订单重量，而把所有可能的匹配罗列出来
SQL = "select a.订单重量,a.订单运费,a.订单编码,a.重量,a.目的省,a.目的市,a.快递公司,a.库房编码,b.重量,b.首重,b.首重收费,b.续重1KG,b.上门服务费,b.目的市 from [订单[ DISCUZ_CODE_0 ]quot; _
& [a1].CurrentRegion.Address(0, 0) & "] a left join [运费标准$] b on a.库房编码=b.库房编码 and a.快递公司=b.快递公司 and a.目的省=b.目的省"
arr = cnn.Execute(SQL).GetRows 'SQL查询结果存放到数组arr
For i = 0 To UBound(arr, 2) '逐行数据
If Not IsNull(arr(0, i)) Then '排除“订单重量”为空值的数据行
If Application.Evaluate(arr(0, i) & arr(8, i)) Then '“订单重量”符合“运费标准”表重量要求，如<=3、>10等
If arr(13, i) <> "省内所有" Then '有“目的市”
a = Split(ds(arr(7, i) & arr(6, i) & arr(4, i) & arr(0, i) & arr(13, i)), ",") '由库房编码、快递公司、目的省、目的市字符串确定的字典条目所有行号数组
For j = 1 To UBound(a) '逐个行号
brr(Val(a(j)), 1) = arr(10, i) + (arr(0, i) - arr(9, i)) * arr(11, i) + arr(12, i) '写订单运费
Next
Else '没有“目的市”
a = Split(d(arr(7, i) & arr(6, i) & arr(4, i) & arr(0, i)), ",") '由库房编码、快递公司、目的省字符串确定的字典条目所有行号数组
For j = 1 To UBound(a) '逐个行号
If brr(Val(a(j)), 1) = "" Then brr(Val(a(j)), 1) = arr(10, i) + (arr(0, i) - arr(9, i)) * arr(11, i) + arr(12, i) '写订单运费，与上面不同如果改行已经有值，则不再覆盖，以确保优先考虑有“目的市”
Next
End If
End If
End If
Next
[b2].Resize(UBound(brr) - 1) = brr '向“订单”工作表B列写数据
cnn.Close
Set cnn = Nothing
End Sub

复制代码

附件：

字典+ADO外连接实现计费表格查询.rar (114.54 KB, 下载次数: 561)

本方本仅为了探讨字典结合ADO查询解决问题的方法，对于数据源已经打开的情况，还是用数组+字典速度更快，方法详见4楼。

该贴已经同步到 zhaogang1960的微博

复制代码

liulang0808 · 发表于 2014-3-7 07:05

谢谢赵版分享，好好学习。

xd3210 · 发表于 2014-3-7 09:38

通用性强，下载学习！

zhaogang1960 · 发表于 2014-3-7 15:49

本帖最后由 zhaogang1960 于 2014-3-10 11:46 编辑

1楼方本仅为了探讨字典结合ADO查询解决问题的方法，对于数据源已经打开的情况，还是用数组+字典速度更快，代码如下：

Sub 计算订单运费字典法()
tt = Timer
Dim a, arr, ary, brr(), i&, j&, s$, d As Object, ds As Object
Set d = CreateObject("scripting.dictionary") '创建字典对象，以储存库房编码、快递公司、目的省字符串确定的行号
Set ds = CreateObject("scripting.dictionary") '创建字典对象，以储存库房编码、快递公司、目的省、目的市字符串确定的行号
arr = [a1].CurrentRegion '“订单”工作表数据写入数组
ReDim brr(2 To UBound(arr), 1 To 1) '重新定义数组，行数等于数据行数
For i = 2 To UBound(arr)
If Len(arr(i, 1)) Then '排除“订单重量”为空值的数据行
s = arr(i, 8) & arr(i, 7) & arr(i, 5) '库房编码、快递公司、目的省字符串
d(s) = d(s) & "," & i '库房编码、快递公司、目的省添加到字典键值，行号添加到字典条目
s = s & arr(i, 6) '库房编码、快递公司、目的省、目的市字符串
ds(s) = ds(s) & "," & i '库房编码、快递公司、目的省、目的市添加到字典键值，行号添加到字典条目
End If
Next
ary = Sheets("运费标准").[a1].CurrentRegion '“运费标准”工作表数据写入数组ary
With Application
For i = 2 To UBound(ary) '逐行数据
s = ary(i, 1) & ary(i, 2) & ary(i, 3) & ary(i, 4) '库房编码、快递公司、目的省、目的市字符串
If ds.Exists(s) Then '如果"运费标准"表中有"目的市"
a = Split(ds(s), ",") '由库房编码、快递公司、目的省、目的市字符串确定的字典条目所有行号数组
For j = 1 To UBound(a) '每个字典ds条目储存的行号
r = Val(a(j)) '行号
If .Evaluate(arr(r, 1) & ary(i, 5)) Then '如果"订单重量"符合"运费标准"表中的重量标准
brr(r, 1) = ary(i, 7) + (arr(r, 1) - ary(i, 6)) * ary(i, 8) + ary(i, 9) '写订单运费
End If
Next
Else '如果"运费标准"表中没有"目的市"
s = ary(i, 1) & ary(i, 2) & ary(i, 3) '库房编码、快递公司、目的省字符串
If d.Exists(s) Then
a = Split(d(s), ",")
For j = 1 To UBound(a)
r = Val(a(j))
If .Evaluate(arr(r, 1) & ary(i, 5)) Then
If Len(brr(r, 1)) = 0 Then brr(r, 1) = ary(i, 7) + (arr(r, 1) - ary(i, 6)) * ary(i, 8) + ary(i, 9) '写订单运费，与上面不同如果改行已经有值，则不再覆盖，以确保优先考虑有“目的市”
End If
Next
End If
End If
Next
End With
[b2].Resize(UBound(brr) - 1) = brr '向“订单”工作表B列写数据
MsgBox Timer - tt
End Sub

复制代码

两种方法比较.rar (124.64 KB, 下载次数: 306)

42921783 · 发表于 2014-3-7 16:42

zhaogang1960 发表于 2014-3-7 15:49
1楼方本仅为了探讨字典结合ADO查询解决问题的方法，对于数据源已经打开的情况，还是用数组+字典速度更快，代 ...

2种方法的结果不同。

zhaogang1960 · 发表于 2014-3-7 16:56

本帖最后由 zhaogang1960 于 2014-3-10 11:48 编辑

42921783 发表于 2014-3-7 16:42
2种方法的结果不同。

把一次的结果复制到一个空列，如J列，再运行另一种方法，用下面公式可以测试出使用有错

=IF(B2<>J2,1,"")
在第一个程序结束时加一句：
Columns("B:B").Copy Range("J1") ' 新加,用来测试两种方法结果是否一致
Sub 主程序()
Call 计算订单运费
Call 计算订单运费字典法
End Sub

运行主程序后，请查看K列是否有 1

两种方法比较.rar (225.7 KB, 下载次数: 132)

42921783 · 发表于 2014-3-7 17:07

zhaogang1960 发表于 2014-3-7 16:56
把一次的结果复制到一个空列，如J列，再运行另一种方法，用下面公式可以测试出使用有错

=IF(B2J2,1,"" ...

K列是有1。

zhaogang1960 · 发表于 2014-3-7 17:21

本帖最后由 zhaogang1960 于 2014-3-10 11:49 编辑

42921783 发表于 2014-3-7 17:07
K列是有1。

请看运行演示及结果：

运行结果.rar (230.01 KB, 下载次数: 64)

42921783 · 发表于 2014-3-7 17:37

zhaogang1960 发表于 2014-3-7 17:21
请看运行演示及结果：

如图，确实是有1出现。

zhaogang1960 · 发表于 2014-3-7 17:40

42921783 发表于 2014-3-7 17:37
如图，确实是有1出现。

你这是什么版本的Excel？
请上传你运行程序后的工作簿我看看

		自动登录	找回密码
密码			免费注册

[原创] 用字典+ADO查询实现计费表格查询

评分

点评

最新热点 /1