Sub GPE()
Dim Sh As Worksheet, lMaxQ As Long, aData As Variant, aResult() As Variant, i As Long, m As Long, n As Long, k As Long, lTmp As Long
Dim lRi As Long, lQr As Long, lZr As Long, lFr As Long, lTo As Long
Set Sh = ActiveSheet
Sh.Range("G4").Resize(1000, 1000).ClearContents
lMaxQ = Sh.Range("D3").Value
aData = Sh.Range("B4:E" & Sh.Cells(&H100000, 1).End(xlUp).Row)
ReDim aResult(1 To UBound(aData, 1) - 1, 1 To 1)
lRi = 1: lFr = 1
For i = 1 To UBound(aData, 1) - 1
If aData(i, 4) > 0 Then
If lZr = lMaxQ Then
lRi = lRi + 1: lQr = 0: lZr = 0
ReDim Preserve aResult(1 To UBound(aResult, 1), 1 To lRi)
If k > 0 Then
i = k - 1: k = 0
GoTo Next_i
End If
End If
lTmp = aData(i, 4)
If lTmp > (lMaxQ - lZr) Then lTmp = (lMaxQ - lZr)
If lTmp > 5 Then lTmp = 5
aResult(i, lRi) = lTmp: aData(i, 4) = aData(i, 4) - lTmp: lQr = lQr + 1: lZr = lZr + lTmp
If aData(i, 4) > 0 And k = 0 Then k = i
End If
If aData(i + 1, 1) <> aData(i, 1) Then
lTo = i
If lQr = 1 Then
For m = lRi - 1 To 1 Step -1
lTmp = 0
For n = lTo To lFr Step -1
If aResult(n, m) > 0 And aResult(n, lRi) = 0 Then
lTmp = lTmp + 1
If aResult(n, m) > 1 Or lTmp > 2 Then
aResult(n, m) = aResult(n, m) - 1
aResult(n, lRi) = 1
If aResult(n, m) = 0 Then aResult(n, m) = Empty
GoTo Check_k
End If
End If
Next
Next
End If
Check_k:
lZr = lMaxQ
If k > 0 Then
i = k - 1: k = 0
Else
lFr = i + 1
End If
End If
Next_i:
Next
Sh.Range("G4").Resize(UBound(aResult, 1), lRi).Value = aResult
End Sub
![""":::":\](/diendan/styles/smilies/cbkg013.gif "sdrts \"\"\":::\":\")
