数组和字典法根据单级BOM计算耗用的例子

HLAI

这几天一直在学习数组和字典法，初步掌握了一点点技巧，再也不会象以前那样N个循环嵌套N次再循环了。。。。。。

附件是今天要解决工作上的一个问题时想出来的拆分BOM表的方法，原来的程序是循环再循环，在回家开着车的时候翻来覆去地想应该如何用字典加快计算速度，忽然想到用字典记录成品在BOM中的开始行号，然后再想到同样可以记录结束行号，这样就能快速地找到成品在BOM中的位置，无需整个BOM循环一次来找数据。

也许有更优化的算法吧？但这也算是我的一点所得，希望能对其他朋友有所启发


Private Sub CommandButton1_Click()
t = Timer
Dim iArr_Data(), iArr_BOM(), iArr_Total(), iArr_Group()
Dim iDict_BOM_S As Object, iDict_BOM_E As Object, iDict_Group As Object
ReDim iArr_Total(1 To 2, 1 To 1)
ReDim iArr_Group(1 To 2, 1 To 1)
Set iDict_BOM_S = CreateObject("Scripting.Dictionary")
Set iDict_BOM_E = CreateObject("Scripting.Dictionary")

With Sh_Data
    .Range("A2:C12408").Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, Key2:=.Range("B2"), Order1:=xlAscending, Header:=xlYes
    iArr_BOM = .Range("A3:C12408")
    iArr_Data = .Range("E3:F" & .Range("E65526").End(xlUp).Row)
    For i = 1 To UBound(iArr_BOM)
        iDict_BOM_E(iArr_BOM(i, 1)) = i
        If iDict_BOM_S.Exists(iArr_BOM(i, 1)) Then
        Else
            iDict_BOM_S(iArr_BOM(i, 1)) = i
        End If
    Next
    Set iDict_Group = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(iArr_Data)
        If iDict_Group.Exists(iArr_Data(i, 1)) Then
            k = iDict_Group(iArr_Data(i, 1))
            iArr_Group(2, k) = iArr_Group(2, k) + iArr_Data(i, 2)
        Else
            n = n + 1
            iDict_Group(iArr_Data(i, 1)) = n
            ReDim Preserve iArr_Group(1 To 2, 1 To n)
            iArr_Group(1, n) = iArr_Data(i, 1)
            iArr_Group(2, n) = iArr_Data(i, 2)
        End If
    Next
    n = 1
    For i = 1 To UBound(iArr_Group, 2)
        s = iDict_BOM_S(iArr_Group(1, i))
        e = iDict_BOM_E(iArr_Group(1, i))
        For x = s To e
            ReDim Preserve iArr_Total(1 To 2, 1 To n)
            iArr_Total(1, n) = iArr_BOM(x, 2)
            iArr_Total(2, n) = iArr_Group(2, i) * iArr_BOM(x, 3)
            n = n + 1
        Next
    Next
    Set iDict_Group = CreateObject("Scripting.Dictionary")
    n = 0
    ReDim iArr_Group(1 To 2, 1 To 1)
    For i = 1 To UBound(iArr_Total, 2)
        If iDict_Group.Exists(iArr_Total(1, i)) Then
            k = iDict_Group(iArr_Total(1, i))
            iArr_Group(2, k) = iArr_Group(2, k) + iArr_Total(2, i)
        Else
            n = n + 1
            iDict_Group(iArr_Total(1, i)) = n
            ReDim Preserve iArr_Group(1 To 2, 1 To n)
            iArr_Group(1, n) = iArr_Total(1, i)
            iArr_Group(2, n) = iArr_Total(2, i)
        End If
    Next
    .Range("H3:I3").Resize(UBound(iArr_Group, 2)) = Application.Transpose(iArr_Group)
    .Range("H2:I" & 2 + UBound(iArr_Group, 2)).Sort Key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes
End With
MsgBox Timer - t
End Sub

HLAI

附件不能上传，只能贴个图了

                   BOM                                         Data                                          Total       
P_Code        M_Code        Use_Qty                P_Code        P_Qty                M_Code        All_Use
成0001        材0001        6.00000                 成1288        42                        
成0001        材0002        3.00000                 成1288        200                        
成0001        材0003        3.00000                 成1293        200                        
成0001        材0005        3.00000                 成1293        200                        
成0001        材0007        3.00000                 成1293        200                        
成0001        材0009        1.00000                 成1293        100                        
成0001        材0018        1.00000                 成1348        100                        
成0001        材0023        1.00000                 成1314        200                        
成0002        材0001        6.00000                 成1314        50                        
成0002        材0002        3.00000                 成1314        50                        
成0002        材0003        3.00000                 成1314        200                        
成0002        材0005        3.00000                 成0782        1                        
成0002        材0007        3.00000                 成0783        100                        
成0002        材0009        1.00000                 成0783        86                        
成0002        材0018        1.00000                 成0464        1                        
成0002        材0023        1.00000                 成0464        1                        
成0002        材0031        3.20000                 成0464        1                        

wzsy2_mrf

感觉不用这么复杂，一个词典足矣，也不用排序。

yjh_27

等附件看效果。开车想问题是大忌，不差那点时间。

HLAI

wzsy2_mrf 发表于 2016-9-10 08:36
感觉不用这么复杂，一个词典足矣，也不用排序。

不错！一个字典足够了！之前是想歪了，思维还是没有拐过来。总是吧数组和字典的作用弄混了。
再写一次的程序的运行速度快了0.03秒而已，但程序本身就精炼了许多。肯思考就有进步！也许还有更精炼的写法吧？
Private Sub CommandButton2_Click()
t = Timer
Dim iArr_Data(), iArr_BOM(), iArr_Total() ', iArr_Group()
Dim iDict_Total As Object
ReDim iArr_Total(1 To 2, 1 To 1)
Set iDict_Total = CreateObject("Scripting.Dictionary")
With Sh_Data
    .Range("H2:I65536").ClearContents
    iArr_BOM = .Range("A3:C12408")
    iArr_Data = .Range("E3:F" & .Range("E65526").End(xlUp).Row)
    n = 0
    For i = 1 To UBound(iArr_Data)
        If iDict_Total.Exists(iArr_Data(i, 1)) Then
            iArr_Total(2, n) = iArr_Total(2, n) + iArr_Data(i, 2)
            iDict_Total(iArr_Data(i, 1)) = iArr_Total(2, n)
        Else
            n = n + 1
            ReDim Preserve iArr_Total(1 To 2, 1 To n)
            iArr_Total(1, n) = iArr_Data(i, 1)
            iArr_Total(2, n) = iArr_Data(i, 2)
            iDict_Total(iArr_Data(i, 1)) = iArr_Total(2, n)
        End If
    Next
    ReDim iArr_Total(1 To 2, 1 To 1)
    n = 0
    For i = 1 To UBound(iArr_BOM)
        If iDict_Total.Exists(iArr_BOM(i, 1)) Then
            If iDict_Total.Exists(iArr_BOM(i, 2)) Then
                k = iDict_Total(iArr_BOM(i, 2))
                iArr_Total(2, k) = iArr_Total(2, k) + iDict_Total(iArr_BOM(i, 1)) * iArr_BOM(i, 3)
            Else
                n = n + 1
                ReDim Preserve iArr_Total(1 To 2, 1 To n)
                iArr_Total(1, n) = iArr_BOM(i, 2)
                iArr_Total(2, n) = iDict_Total(iArr_BOM(i, 1)) * iArr_BOM(i, 3)
                iDict_Total(iArr_BOM(i, 2)) = n
            End If
        End If
    Next
    .Range("H3:I3").Resize(UBound(iArr_Total, 2)) = Application.Transpose(iArr_Total)
    .Range("H2:I" & 2 + UBound(iArr_Total, 2)).Sort Key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes
End With
MsgBox Timer - t
End Sub
还是不能上传附件。。。。。。。。。。。

HLAI

原来是浏览器问题，换IE就OK了

zhjlgaojuan

Sub test()
Dim DDic As Object, TDic As Object, TArr
tt = Timer
Set DDic = CreateObject("scripting.dictionary")
Set TDic = CreateObject("scripting.dictionary")
TArr = Range("e3:f" & [f3].End(xlDown).Row)
For i = 1 To UBound(TArr)
  DDic(TArr(i, 1)) = DDic(TArr(i, 1)) + TArr(i, 2)
Next
TArr = Range("a3:c" & [c3].End(xlDown).Row)
For i = 1 To UBound(TArr)
  If DDic.exists(TArr(i, 1)) Then TDic(TArr(i, 2)) = TDic(TArr(i, 2)) + DDic(TArr(i, 1)) * TArr(i, 3)
Next
[h3].Resize(TDic.Count, 1) = WorksheetFunction.Transpose(TDic.keys)
[i3].Resize(TDic.Count, 1) = WorksheetFunction.Transpose(TDic.items)
Range("H3:I" & 2 + TDic.Count).Sort Key1:=Range("H3"), Order1:=xlAscending, Header:=xlNo
Debug.Print Format(Timer - tt, "0.000000")
End Sub
双字典,好像没那么复杂啊

HLAI

zhjlgaojuan朋友的双字典方法已经明了，语句上更精炼。如果继续用单字典，我只能精炼到下面的语句。比之前的快0.02秒，但和zhjlgaojuan朋友的时间一样。

Sub testa()
t = Timer
Dim iArr_Data(), iArr_BOM(), iArr_Total() ', iArr_Group()
Dim iDict_Total As Object
ReDim iArr_Total(1 To 2, 1 To 1)
Set iDict_Total = CreateObject("Scripting.Dictionary")
With Sh_Data
    .Range("H2:I65536").ClearContents
    iArr_BOM = .Range("A3:C12408")
    iArr_Data = .Range("E3:F" & .Range("E65526").End(xlUp).Row)
    n = 0
    For i = 1 To UBound(iArr_Data)
        iDict_Total(iArr_Data(i, 1)) = iDict_Total(iArr_Data(i, 1)) + iArr_Data(i, 2)
    Next
    ReDim iArr_Total(1 To 2, 1 To 1)
    n = 0
    For i = 1 To UBound(iArr_BOM)
        If iDict_Total.Exists(iArr_BOM(i, 1)) Then
            If iDict_Total.Exists(iArr_BOM(i, 2)) Then
                k = iDict_Total(iArr_BOM(i, 2))
                iArr_Total(2, k) = iArr_Total(2, k) + iDict_Total(iArr_BOM(i, 1)) * iArr_BOM(i, 3)
            Else
                n = n + 1
                ReDim Preserve iArr_Total(1 To 2, 1 To n)
                iArr_Total(1, n) = iArr_BOM(i, 2)
                iArr_Total(2, n) = iDict_Total(iArr_BOM(i, 1)) * iArr_BOM(i, 3)
                iDict_Total(iArr_BOM(i, 2)) = n
            End If
        End If
    Next
    .Range("H3:I3").Resize(UBound(iArr_Total, 2)) = Application.Transpose(iArr_Total)
    .Range("H2:I" & 2 + UBound(iArr_Total, 2)).Sort Key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes
End With
MsgBox Timer - t
End Sub

wzsy2_mrf

还是用双词典，速度提升一倍

1. Sub test3()
   
2.     t = Timer
   
3.     Dim iArr_Data(), iArr_BOM(), iArr_Total(), i&, j&, n&, xms ', iArr_Group()
   
4.     Dim iDict_Total As Object
   
5.     ReDim iArr_Total(1 To 10000, 1 To 2)
   
6.     Set iDict_Total = CreateObject("Scripting.Dictionary")
   
7.     Set iDict_M = CreateObject("Scripting.Dictionary")
   
8.     With Sh_Data
   
9.         .Range("H2:I65536").ClearContents
   
10.         iArr_BOM = .Range("A3:C12408")
    
11.         iArr_Data = .Range("E3:F" & .Range("E65526").End(xlUp).Row)
    
12.         For i = 1 To UBound(iArr_BOM)
    
13.             If Not iDict_Total.exists(iArr_BOM(i, 1)) Then
    
14.                 iDict_Total(iArr_BOM(i, 1)) = i
    
15.             Else
    
16.                 iDict_Total(iArr_BOM(i, 1)) = iDict_Total(iArr_BOM(i, 1)) & "++" & i
    
17.             End If
    
18.         Next
    
19.         n = 0
    
20.         For i = 1 To UBound(iArr_Data)
    
21.             If iDict_Total.exists(iArr_Data(i, 1)) Then
    
22.                 xms = Split(iDict_Total(iArr_Data(i, 1)), "++")
    
23.                 For j = 0 To UBound(xms)
    
24.                     If Not iDict_M.exists(iArr_BOM(xms(j), 2)) Then
    
25.                         n = n + 1
    
26.                         iDict_M(iArr_BOM(xms(j), 2)) = n
    
27.                         iArr_Total(n, 1) = iArr_BOM(xms(j), 2)
    
28.                         iArr_Total(n, 2) = iArr_BOM(xms(j), 3) * iArr_Data(i, 2)
    
29.                     Else
    
30.                         iArr_Total(iDict_M(iArr_BOM(xms(j), 2)), 2) = iArr_Total(iDict_M(iArr_BOM(xms(j), 2)), 2) + iArr_BOM(xms(j), 3) * iArr_Data(i, 2)
    
31.                     End If
    
32.                 Next
    
33.             End If
    
34.         Next
    
35.     .Range("M3").Resize(n, 2) = iArr_Total
    
36.     .Range("M3").Resize(n, 2).Sort Key1:=.Range("M3"), Order1:=xlAscending, Header:=xlNo
    
37. End With
    
38. MsgBox Timer - t
    
39. End Sub
    

复制代码

wzsy2_mrf

如果用三词典，将中间数组先分类汇总速度还将会快许多。