- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("sheet2")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a1:c" & r)
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- m = 1
- ReDim brr(1 To 2, 1 To m)
- Else
- brr = d(arr(i, 2))
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To 2, 1 To m)
- End If
- brr(1, m) = arr(i, 1)
- brr(2, m) = arr(i, 3)
- d(arr(i, 2)) = brr
- Next
- End With
- With Worksheets("sheet1")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- .Range("c2:h" & r).ClearContents
- arr = .Range("a2:h" & r)
- For i = 1 To UBound(arr)
- n = 3
- sl = arr(i, 2)
- If d.exists(arr(i, 1)) Then
- brr = d(arr(i, 1))
- For j = 1 To UBound(brr, 2)
- If brr(2, j) > 0 Then
- If brr(2, j) > sl Then
- arr(i, n) = brr(1, j)
- arr(i, n + 1) = sl
- brr(2, j) = brr(2, j) - sl
- sl = 0
- Else
- arr(i, n) = brr(1, j)
- arr(i, n + 1) = brr(2, j)
- sl = sl - brr(2, j)
- brr(2, j) = 0
- End If
- n = n + 2
- End If
- If sl = 0 Then
- Exit For
- End If
- Next
- d(arr(i, 1)) = brr
- End If
- Next
- .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
- End With
- End Sub
复制代码 |