|
本帖最后由 yiyiyicz 于 2014-1-10 19:32 编辑
一个应用实例
附件
Book1.rar
(9.29 KB, 下载次数: 611)
说明见附件
- Sub tt02()
- '===================
- '====BOM展开实例====
- '===================
- Dim Arr, Brr
- Dim D1 As Object, D2 As Object, Scol As String, Srow As String, i&, j&
- Dim Item As CItem
- Arr = Sheet1.Range("a3:e14") '取源数据
- Set D1 = CreateObject("Scripting.Dictionary") '后期绑定引用字典对象
- Set D2 = CreateObject("scripting.dictionary")
- For i = 1 To UBound(Arr) '建立对象
- Set Item = New CItem
- Item.Name = i & "|" & Arr(i, 2)
- Item.Icol = i
- Item.Quantity = Arr(i, 4)
- D1.Add i & "|" & Arr(i, 2), Item
- D2(Arr(i, 2)) = D2(Arr(i, 2))
- Arr(i, 5) = 1
- Set Item = Nothing
- Next i
- '====建立邻接矩阵Brr====
- ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr))
- For i = 1 To UBound(Arr)
- For j = i To UBound(Arr)
- If i = j Or Arr(i, 1) < Arr(j, 1) Then
- Brr(i, j) = 1
- Else
- Exit For
- End If
- Next
- Next
- '====利用邻接矩阵Brr,展开BOM====
- '注意,此邻接矩阵是方阵,列标就是行标的转置
- For i = 1 To D1.Count
- Scol = CStr(i & "|" & Arr(i, 2)) '列标
- For j = 1 To D1.Count
- Srow = CStr(j & "|" & Arr(j, 2)) '行标
- 'Debug.Print D1(Srow).Icol & " " & Srow & " " & Brr(D1(Srow).Icol, i)
- If Not IsEmpty(Brr(D1(Srow).Icol, i)) Then
- 'D2(Arr(i, 2)) = D2(Arr(i, 2)) * D1(Srow).Quantity
- Arr(i, 5) = Arr(i, 5) * D1(Srow).Quantity
- End If
- If j = i + 1 Then Exit For
- Next j
- Next i
- For i = 1 To UBound(Arr)
- D2(Arr(i, 2)) = D2(Arr(i, 2)) + Arr(i, 5)
- Next i
- '====结果复制到sheet1中====
- Sheet1.Range("b16").Resize(D2.Count, 1) = Application.Transpose(D2.keys)
- Sheet1.Range("d16").Resize(D2.Count, 1) = Application.Transpose(D2.items)
- Sheet1.Range("a24").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
- End Sub
复制代码 |
|