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
), nhưng mà với trình độ code gà của mình thì cảm nhận không đủ để giải bài toán này. Đã vào và âm thầm đi ra không nói gì =))
![""":::":\](/diendan/styles/smilies/cbkg013.gif "sdrts \"\"\":::\":\")
