求组，见附件，各位高手大哥帮忙小弟，万分感谢

kingqsy

附件中有说明，拜托给位高手帮忙，小弟万分感谢。

kingqsy

有人帮忙吗？

kingqsy

求组啊 没人看嘛？

shuyee

Sub test()
Dim tmpV As Variant, i%, j%, outArr1() As String, outArr2() As Integer, outArr3() As Byte, resL As Byte, k%, m%, curQty As Byte, curNo%
tmpV = Range("A3:B12").Value
i = UBound(tmpV)
For i = 1 To i
    k = Application.RoundUp((resL + tmpV(i, 2)) / 32, 0)
    ReDim Preserve outArr1(1 To j + k)
    ReDim Preserve outArr2(1 To j + k)
    ReDim Preserve outArr3(1 To j + k)
    For m = 1 To k
        outArr1(j + m) = tmpV(i, 1)
        outArr2(j + m) = 32 - IIf(m = 1, resL, 0)
        curQty = outArr2(j + m) Mod 32
        curNo = curNo + IIf(curQty, 0, 1)
        outArr3(j + m) = curNo
    Next
    j = j + m - 1
    resL = (resL + tmpV(i, 2)) Mod 32
    If resL Then
        outArr2(j) = resL
        curQty = curQty + resL
    End If
Next
ReDim tmpV(1 To j, 1 To 3)
For k = 1 To j
    tmpV(k, 1) = outArr1(k)
    tmpV(k, 2) = outArr2(k)
    tmpV(k, 3) = outArr3(k)
Next
Range("H3").Resize(k - 1, 3) = tmpV
End Sub

kingqsy

shuyee 发表于 2013-12-9 23:47
Sub test()
Dim tmpV As Variant, i%, j%, outArr1() As String, outArr2() As Integer, outArr3() As Byt ...

非常感谢 这个大哥 有机会 联系下 174451275  QQ 我的

kingqsy

shuyee 发表于 2013-12-9 23:47
Sub test()
Dim tmpV As Variant, i%, j%, outArr1() As String, outArr2() As Integer, outArr3() As Byt ...

附件 图片 红色区域  有点不对 ，麻烦 看一下 是不是我哪里弄错咯

kingqsy

kingqsy 发表于 2013-12-11 09:31
附件 图片 红色区域  有点不对 ，麻烦 看一下 是不是我哪里弄错咯

数量列 哪里 应该是 1 1 1 1  但是 宏出来时 1 2 3 4

kingqsy

还有人帮助吗？ 3楼大哥 理解对咯 但是 宏应该还有点问题  还有人帮助下吗？》

shuyee

Sub test()
Dim tmpV As Variant, i%, j%, outArr1() As String, outArr2() As Integer, outArr3() As Byte, resL As Byte, k%, m%, curQty As Byte, curNo%
tmpV = Range("A3:B12").Value
i = UBound(tmpV)
For i = 1 To i
     k = Application.RoundUp((IIf(resL > 0, 32 - resL, 0) + tmpV(i, 2)) / 32, 0)    'resL记录托盘余数，如果有余数，用32减去它，就是本次要分配的总量
     ReDim Preserve outArr1(1 To j + k) '引入k，可快速确定本次分配需要的托盘数
     ReDim Preserve outArr2(1 To j + k)
     ReDim Preserve outArr3(1 To j + k)
     For m = 1 To k
         outArr1(j + m) = tmpV(i, 1)    '记录品名
         curNo = curNo + IIf(resL > 0, 0, 1)   '如果上次分配后有余数，则不启用新托盘
         outArr3(j + m) = curNo
         curQty = IIf(resL = 0, 32, resL)   '上次的余数，就是本次分配的可用量，但如果上次为0，则本次可分配32
         outArr2(j + m) = Application.Min(curQty, tmpV(i, 2), 32)  '只能取可分配的最小数
         resL = curQty - outArr2(j + m) '扣除实际分配量后，即为本次分配的余数
         tmpV(i, 2) = tmpV(i, 2) - outArr2(j + m)   '扣除后，重置该品名的待分配量
     Next
     j = j + m - 1  '行号要增加，-1，是因为循环后,m比k大1
Next
ReDim tmpV(1 To j, 1 To 3) '重写数组，一次输出，高效
For k = 1 To j
     tmpV(k, 1) = outArr1(k)
     tmpV(k, 2) = outArr2(k)
     tmpV(k, 3) = outArr3(k)
Next
Range("H3").Resize(k - 1, 3) = tmpV    '输出
End Sub

kingqsy

shuyee 发表于 2013-12-14 22:26
Sub test()
Dim tmpV As Variant, i%, j%, outArr1() As String, outArr2() As Integer, outArr3() As By ...

谢谢  为测试一下