ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1237|回复: 2

[分享] 金蝶K/3采购订单提取最后采购价格。

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-15 13:46 | 显示全部楼层 |阅读模式
做了个模板,主要是把从金蝶K/3系统中引出来的采购订单按照月为单位,提取最后采购价格。
代码如下,我自己测算可以处理7个工作表加起来有叁拾万条记录。
其中解决了字典只能搞定65536的界限。
具体代码如下,谁有需要,可以提供数据源,我们一起研究。
同时欢迎大师指点。谢谢!
  1. Sub 提取订单信息()
  2. Application.ScreenUpdating = False
  3. Dim ar, cr, dr
  4. Dim br(65536, 4)
  5. Dim a, c, d, x, y, r, rx, ry, n, item
  6. Dim kw As New 数组
  7. Set qty = CreateObject("Scripting.Dictionary") '创建一个字典对象
  8. Set amt = CreateObject("Scripting.Dictionary")  '创建一个字典对象
  9. Set Key = CreateObject("Scripting.Dictionary") '创建一个字典对象
  10. '订单2012
  11. For Each sht In Worksheets
  12. If Left(sht.Name, 2) = "订单" Then
  13. sht.Activate: ar = [a1].CurrentRegion
  14. riqi = kw.所在列(ar, "日期", 1): cur = kw.所在列(ar, "币别", 1): pn = kw.所在列(ar, "物料长代码", 1): 数量 = kw.所在列(ar, "数量", 1): 金额 = kw.所在列(ar, "价税合计", 1): huilv = kw.所在列(ar, "汇率", 1): um = kw.所在列(ar, "单位", 1)
  15. For x = 2 To UBound(ar)
  16.     sr = Format(ar(x, riqi), "yyyymm") & "join" & ar(x, cur) & "join" & ar(x, pn) & "join" & ar(x, um)
  17.     sl = ar(x, 数量)
  18.     If ar(x, cur) = "人民币" Then je = ar(x, 金额)
  19.     If ar(x, cur) <> "人民币" Then je = ar(x, 金额) * ar(x, huilv) * 1.287
  20.     If ar(x, riqi) <> "" Then
  21.         If qty.exists(sr) = False Then qty(sr) = qty(sr) + sl: amt(sr) = amt(sr) + je
  22.     End If
  23. Next x
  24. End If
  25. If qty.Count > 0 Then
  26.     Sheets("总表").Activate: ' Sheets("总表").Cells.ClearContents
  27.     rx = Cells(Rows.Count, 1).End(xlUp).Row
  28.     ry = Cells(1, Columns.Count).End(xlToLeft).Column
  29.     Cells(rx + 1, 1).Resize(qty.Count, 1) = Application.Transpose(qty.keys)
  30.     ar = Range(Cells(rx + 1, 1), Cells(rx + qty.Count, 5))
  31.     For x = 1 To qty.Count
  32.         ar(x, 2) = Split(ar(x, 1), "join")(0)
  33.         ar(x, 3) = Split(ar(x, 1), "join")(1)
  34.         ar(x, 4) = Split(ar(x, 1), "join")(2)
  35.         ar(x, 5) = Split(ar(x, 1), "join")(3)
  36.     Next x
  37.     Cells(rx + 1, 1).Resize(UBound(ar), UBound(ar, 2)) = ar
  38.     Cells(rx + 1, 6).Resize(qty.Count, 1) = Application.Transpose(qty.items)
  39.     Cells(rx + 1, 7).Resize(qty.Count, 1) = Application.Transpose(amt.items)
  40.     qty.RemoveAll: amt.RemoveAll
  41. End If
  42. Next sht
  43. [a1].Resize(1, 7) = Split("key,期间,币别,料号,单位,数量,金额", ",")
  44. 'Stop
  45. Application.ScreenUpdating = True
  46. End Sub
  47. Sub 再次提取找到最后单价()
  48. Application.ScreenUpdating = False
  49. Dim ar, cr, dr
  50. Dim br(65536, 4)
  51. Dim a, c, d, x, y, r, rx, ry, n, item
  52. Dim kw As New 数组
  53. Set d = CreateObject("Scripting.Dictionary") '创建一个字典对象
  54. Set amt = CreateObject("Scripting.Dictionary")  '创建一个字典对象
  55. Sheets("总表").Activate
  56. '排序
  57.     ActiveWorkbook.Worksheets("总表").Sort.SortFields.Clear
  58.     ActiveWorkbook.Worksheets("总表").Sort.SortFields.Add2 Key:=Range("B2"), _
  59.         SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
  60.     With ActiveWorkbook.Worksheets("总表").Sort
  61.         .SetRange Range("A2:G1048576")
  62.         .Header = xlNo
  63.         .MatchCase = False
  64.         .Orientation = xlTopToBottom
  65.         .SortMethod = xlPinYin
  66.         .Apply
  67.     End With
  68. ar = [a1].CurrentRegion
  69. n = InputBox("输入最后期间")
  70. If n = "" Or n * 1 < 201501 Then n = 999999
  71. For x = 2 To UBound(ar)
  72.     sr = ar(x, 4) & "join" & ar(x, 5)
  73.     If d.exists(sr) = False And n * 1 >= ar(x, 2) Then d(sr) = ar(x, 1) & "join" & Format(ar(x, 7) / ar(x, 6), "0.0000")
  74. Next x
  75. Sheets("最后价格").Activate: Cells.ClearContents
  76. [a2].Resize(d.Count, 1) = Application.Transpose(d.items)
  77. rx = Cells(Rows.Count, 1).End(xlUp).Row
  78. ry = Cells(1, Columns.Count).End(xlToLeft).Column
  79. ar = Range(Cells(1, 1), Cells(rx, 6))
  80. For x = 2 To d.Count + 1
  81.     ar(x, 2) = Split(ar(x, 1), "join")(0)
  82.     ar(x, 3) = Split(ar(x, 1), "join")(1)
  83.     ar(x, 4) = Split(ar(x, 1), "join")(2)
  84.     ar(x, 5) = Split(ar(x, 1), "join")(3)
  85.     ar(x, 6) = Split(ar(x, 1), "join")(4)
  86. '    ar(x, 7) = Split(ar(x, 1), "join")(5)
  87. '    ar(x, 8) = Split(ar(x, 1), "join")(6)
  88.    
  89. Next x
  90. [a1].Resize(UBound(ar), UBound(ar, 2)) = ar
  91. [a1].Resize(1, 6) = Split("key,期间,币别,料号,单位,单价", ",")
  92. 'Stop
  93. Application.ScreenUpdating = True
  94. End Sub
复制代码


TA的精华主题

TA的得分主题

发表于 2019-1-15 20:00 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
意yin这个案例,觉用sql做个查询更快,伪代码如:select 料号,单价 from shit where 料号&日期 in (select 料号&max(日期) from shit  group by 料号)

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 20:11 | 显示全部楼层
的确是使用ADO要比用字典更快。可惜我还在研究ADO,谁能帮下我。

因为这样的例子还有很多,例如之前发的一个固定资产的模板也可以用ADO来实现。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 16:05 , Processed in 3.394610 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表