|
做了个模板,主要是把从金蝶K/3系统中引出来的采购订单按照月为单位,提取最后采购价格。
代码如下,我自己测算可以处理7个工作表加起来有叁拾万条记录。
其中解决了字典只能搞定65536的界限。
具体代码如下,谁有需要,可以提供数据源,我们一起研究。
同时欢迎大师指点。谢谢!
- Sub 提取订单信息()
- Application.ScreenUpdating = False
- Dim ar, cr, dr
- Dim br(65536, 4)
- Dim a, c, d, x, y, r, rx, ry, n, item
- Dim kw As New 数组
- Set qty = CreateObject("Scripting.Dictionary") '创建一个字典对象
- Set amt = CreateObject("Scripting.Dictionary") '创建一个字典对象
- Set Key = CreateObject("Scripting.Dictionary") '创建一个字典对象
- '订单2012
- For Each sht In Worksheets
- If Left(sht.Name, 2) = "订单" Then
- sht.Activate: ar = [a1].CurrentRegion
- 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)
- For x = 2 To UBound(ar)
- sr = Format(ar(x, riqi), "yyyymm") & "join" & ar(x, cur) & "join" & ar(x, pn) & "join" & ar(x, um)
- sl = ar(x, 数量)
- If ar(x, cur) = "人民币" Then je = ar(x, 金额)
- If ar(x, cur) <> "人民币" Then je = ar(x, 金额) * ar(x, huilv) * 1.287
- If ar(x, riqi) <> "" Then
- If qty.exists(sr) = False Then qty(sr) = qty(sr) + sl: amt(sr) = amt(sr) + je
- End If
- Next x
- End If
- If qty.Count > 0 Then
- Sheets("总表").Activate: ' Sheets("总表").Cells.ClearContents
- rx = Cells(Rows.Count, 1).End(xlUp).Row
- ry = Cells(1, Columns.Count).End(xlToLeft).Column
- Cells(rx + 1, 1).Resize(qty.Count, 1) = Application.Transpose(qty.keys)
- ar = Range(Cells(rx + 1, 1), Cells(rx + qty.Count, 5))
- For x = 1 To qty.Count
- ar(x, 2) = Split(ar(x, 1), "join")(0)
- ar(x, 3) = Split(ar(x, 1), "join")(1)
- ar(x, 4) = Split(ar(x, 1), "join")(2)
- ar(x, 5) = Split(ar(x, 1), "join")(3)
- Next x
- Cells(rx + 1, 1).Resize(UBound(ar), UBound(ar, 2)) = ar
- Cells(rx + 1, 6).Resize(qty.Count, 1) = Application.Transpose(qty.items)
- Cells(rx + 1, 7).Resize(qty.Count, 1) = Application.Transpose(amt.items)
- qty.RemoveAll: amt.RemoveAll
- End If
- Next sht
- [a1].Resize(1, 7) = Split("key,期间,币别,料号,单位,数量,金额", ",")
- 'Stop
- Application.ScreenUpdating = True
- End Sub
- Sub 再次提取找到最后单价()
- Application.ScreenUpdating = False
- Dim ar, cr, dr
- Dim br(65536, 4)
- Dim a, c, d, x, y, r, rx, ry, n, item
- Dim kw As New 数组
- Set d = CreateObject("Scripting.Dictionary") '创建一个字典对象
- Set amt = CreateObject("Scripting.Dictionary") '创建一个字典对象
- Sheets("总表").Activate
- '排序
- ActiveWorkbook.Worksheets("总表").Sort.SortFields.Clear
- ActiveWorkbook.Worksheets("总表").Sort.SortFields.Add2 Key:=Range("B2"), _
- SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
- With ActiveWorkbook.Worksheets("总表").Sort
- .SetRange Range("A2:G1048576")
- .Header = xlNo
- .MatchCase = False
- .Orientation = xlTopToBottom
- .SortMethod = xlPinYin
- .Apply
- End With
- ar = [a1].CurrentRegion
- n = InputBox("输入最后期间")
- If n = "" Or n * 1 < 201501 Then n = 999999
- For x = 2 To UBound(ar)
- sr = ar(x, 4) & "join" & ar(x, 5)
- 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")
- Next x
- Sheets("最后价格").Activate: Cells.ClearContents
- [a2].Resize(d.Count, 1) = Application.Transpose(d.items)
- rx = Cells(Rows.Count, 1).End(xlUp).Row
- ry = Cells(1, Columns.Count).End(xlToLeft).Column
- ar = Range(Cells(1, 1), Cells(rx, 6))
- For x = 2 To d.Count + 1
- ar(x, 2) = Split(ar(x, 1), "join")(0)
- ar(x, 3) = Split(ar(x, 1), "join")(1)
- ar(x, 4) = Split(ar(x, 1), "join")(2)
- ar(x, 5) = Split(ar(x, 1), "join")(3)
- ar(x, 6) = Split(ar(x, 1), "join")(4)
- ' ar(x, 7) = Split(ar(x, 1), "join")(5)
- ' ar(x, 8) = Split(ar(x, 1), "join")(6)
-
- Next x
- [a1].Resize(UBound(ar), UBound(ar, 2)) = ar
- [a1].Resize(1, 6) = Split("key,期间,币别,料号,单位,单价", ",")
- 'Stop
- Application.ScreenUpdating = True
- End Sub
复制代码
|
|