'假设只有一级子阶料号,,,
Option Explicit
Sub test()
Dim arr, dic, i, j, t, m
Set dic = CreateObject("scripting.dictionary")
arr = Sheets("bom").[a1].CurrentRegion
For i = 2 To UBound(arr, 1)
If dic.exists(arr(i, 1)) Then
t = dic(arr(i, 1))
ReDim Preserve t(UBound(t) + 2)
t(UBound(t) - 1) = arr(i, 2): t(UBound(t)) = arr(i, 3)
dic(arr(i, 1)) = t
Else
ReDim t(1)
t(0) = arr(i, 2): t(1) = arr(i, 3)
dic(arr(i, 1)) = t
End If
Next
arr = Sheets("sheet1").[a1].CurrentRegion
ReDim brr(1 To 10 ^ 5, 1 To 4) '最多支持10^5行
For i = 2 To UBound(arr, 1)
If Len(arr(i, 1)) Then
m = m + 1
brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2): brr(m, 4) = arr(i, 4)
If dic.exists(arr(i, 2)) Then
t = dic(arr(i, 2))
For j = 0 To UBound(t) Step 2
m = m + 1
brr(m, 2) = arr(i, 2): brr(m, 3) = t(j): brr(m, 4) = t(j + 1) * arr(i, 4)
Next
End If
End If
Next
With Sheets("sheet1").[f2]
.Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
End With
End Sub |