|
这个问题我几年前曾琢磨过，当时使用集合解决的，代码很烦琐，效果也不是很好。 套用楼主的例子也是消耗了30根，比彭兄的稍省了一点料，呵呵。 Sub Northwolves()
Application.ScreenUpdating = False
Dim all As New Collection, arr, i As Integer, j As Integer, k As Integer, changdu As Integer, y(), s() As String, t(), n()
arr = Sheet1.[a5:b17]
For i = 1 To UBound(arr)
For j = 1 To arr(i, 2)
all.Add arr(i, 1)
Next
Next
i = 0
j = 0
Do While all.Count > 0
ReDim Preserve y(1, i)
y(1, i) = 6300
k = 1
Do While k <= all.Count
changdu = all(k)
If changdu <= y(1, i) Then
y(1, i) = y(1, i) - changdu
y(0, i) = y(0, i) & " " & all(k)
j = j + 1
all.Remove k
If all.Count = 0 Then Exit Do
Else
k = k + 1
End If
Loop
s() = Split(Trim(y(0, i)), " ")
ReDim t(0)
ReDim n(0)
t(0) = s(0)
n(0) = 1
If UBound(s) > 0 Then
For k = 1 To UBound(s)
If s(k) = t(UBound(t)) Then
n(UBound(n)) = n(UBound(n)) + 1
Else
ReDim Preserve t(UBound(t) + 1)
ReDim Preserve n(UBound(n) + 1)
t(UBound(t)) = s(k)
n(UBound(n)) = 1
End If
Next
End If
ReDim s(UBound(t))
For k = 0 To UBound(t)
s(k) = t(k) & "*" & n(k)
Next
y(0, i) = Join(s, ",")
y(1, i) = 6300 - y(1, i)
i = i + 1
Loop
Sheet2.[m8].Resize(i, 2) = WorksheetFunction.Transpose(y)
Application.ScreenUpdating = True
End Sub | 
楼主: kowloon
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-3-27 15:39
