dividing a number into equal(ish) whole parts where individual value cant be more than a set maximum

[jhonty4]

i have range of cells sheet1.range ("E12:E19") containing numbers like 510,411,300,100,80. Sheet1.cell("O6") contains the maximum a number can be say 100. what i want to do is , Divide the numbers in Sheet1.range("E12:E19") into equalish whole parts such that none of the resulting number is greater than 100 and print resulting numbers in Sheet2 starting from sheet2.range("G31")

Shee1.Marker	Plies
A	411
B	100
C	300
d	100

<tbody>
</tbody>

will become

Sheet2 Marker	Plies
A	82
A	82
A	82
A	82
A	83

<tbody>
</tbody>

..... and so on
i have managed to divide it into equal parts but still can't figure out how to make last Row in above table as 82+1 instead of 82 this is the code i have used

Dim i, lays, max, q, j, filled, remaind As Integer
Dim lrlastrow As Long
lrlastrow = Range("A" & Rows.Count).End(xlUp).Row
max = 100
filled = 1
    For i = 12 To 19
    ' end the loop if lays end
        If Range("E" & i).Value = "" Then
            End
        Else
                If Range("E" & i).Value <= max Then
                         Sheet2.Range("B" & 30 + filled).Value = filled 'number
                        Sheet2.Range("C" & 30 + filled).Value = Sheet1.Range("D" & i).Value 'marker
                        Sheet2.Range("G" & 30 + filled).Value = Sheet1.Range("E" & i).Value 'plies
                         filled = filled + 1
                Else
                
                                  q = Range("E" & i).Value                           
                                  lays = 1                        
                           
                                              Do While q >= max
                                              q = Range("E" & i).Value \ lays
                                              remaind = (Range("E" & i).Value Mod lays)
                                              lays = lays + 1
                                      Loop
                               
                              Range("R" & i).Value = lays - 1
                             
                           ' printing the lays
                             For j = 1 To lays - 1
                                               Sheet2.Range("B" & 30 + filled).Value = filled 'number                                               Sheet2.Range("C" & 30 + filled).Value = Sheet1.Range("D" & i).Value 'marker
                                               Sheet2.Range("G" & 30 + filled).Value = q 'plies
                                               filled = filled+1
                            Next j
                End If
          End If
      Next i
End sub

 

[jhonty4]

Like this?

Sub Distribute()
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, rws As Long, main As Long, extra As Long, mx As Long
  
  a = Sheets("Sheet1").Range("D12:E19").Value
  mx = Sheets("Sheet1").Range("O6").Value
  ReDim b(1 To Rows.Count, 1 To 1)
  ReDim c(1 To Rows.Count, 1 To 2)
  For i = 1 To UBound(a)
    If a(i, 2) > 0 Then
      rws = (Int(a(i, 2) / mx) + IIf(a(i, 2) / mx = Int(a(i, 2) / mx), 0, 1))
      main = Int(a(i, 2) / rws)
      extra = a(i, 2) - rws * main
      For j = 1 To rws
        k = k + 1: b(k, 1) = main + IIf(j > extra, 0, 1)
        c(k, 1) = k: c(k, 2) = a(i, 1)
      Next j
    End If
  Next i
  Sheets("Sheet2").Range("G31").Resize(k).Value = b
  Sheets("Sheet2").Range("B31:C31").Resize(k).Value = c
End Sub

This is magical . Thanks a lot peter i will spend my time studying the code.

 

[Ombir]

Hi ombir ... Above code works good but doesnt give the desired result when the number is exactly divisible by max(ie 100 in this case ) for example 500 should be 100*5 but the result it is giving is 84+84+83+83+83+83 i couldn't spot this error in my code too untill i compared results with pete's code. Also i have no clue as to how can i ammend the code such that the serial number and respective marker value is also printed for the breakup.

Bad testing from my end Jhonty. This should work perfectly with your new requirements:

Sub jhonty()
Dim i       As Long
Dim c       As Long
Dim j       As Long
Dim r       As Long
Dim maxnum  As Long
Dim spnum   As Long
Dim f       As Integer
Dim ar      As Variant
Dim ws1     As Worksheet
Dim ws2     As Worksheet

Set ws1 = Sheets("Sheet1"): Set ws2 = Sheets("Sheet2")

maxnum = ws1.Range("O6"): r = 31

With ws1
    For Each cell In .Range("E12:E19")
        If Not IsEmpty(cell) Then
            f = IIf(cell = maxnum, Application.Floor(cell / maxnum, 1), Application.Floor(cell / maxnum + 1, 1))
            ReDim ar(1 To f, 1 To 2)
            spnum = Application.Floor(cell / f, 1)
            j = cell Mod f
            For i = 1 To f
                If j <> 0 Then
                    ar(i, 2) = spnum + 1: c = c + 1: ar(i, 1) = c
                    j = j - 1
                Else
                    ar(i, 2) = spnum: c = c + 1: ar(i, 1) = c
                End If
            Next
        ws2.Cells(r, "G").Resize(f, 1) = Application.Index(ar, , 2)
        ws2.Cells(r, "C").Resize(f, 1) = cell.Offset(, -1)
        ws2.Cells(r, "B").Resize(f, 1) = Application.Index(ar, , 1)
        r = r + f
        End If
    Next
End With
End Sub

 

[Peter_SSs]

This is magical . Thanks a lot peter i will spend my time studying the code.

Cheers, glad it was what you wanted.

 

[Ombir]

Again left one silly mistake. Try this updated version:

Sub jhonty()
Dim i       As Long
Dim c       As Long
Dim j       As Long
Dim r       As Long
Dim maxnum  As Long
Dim spnum   As Long
Dim f       As Integer
Dim ar      As Variant
Dim ws1     As Worksheet
Dim ws2     As Worksheet

Set ws1 = Sheets("Sheet1"): Set ws2 = Sheets("Sheet2")

maxnum = ws1.Range("O6"): r = 31

With ws1
    For Each cell In .Range("E12:E19")
        If Not IsEmpty(cell) Then
            f = IIf(cell Mod maxnum = 0, cell / maxnum, Application.Floor(cell / maxnum + 1, 1))
            ReDim ar(1 To f, 1 To 2)
            spnum = Application.Floor(cell / f, 1)
            j = cell Mod f
            For i = 1 To f
                c = c + 1
                If j <> 0 Then
                    ar(i, 2) = spnum + 1: ar(i, 1) = c
                    j = j - 1
                Else
                    ar(i, 2) = spnum: ar(i, 1) = c
                End If
            Next
        ws2.Cells(r, "G").Resize(f, 1) = Application.Index(ar, , 2)
        ws2.Cells(r, "C").Resize(f, 1) = cell.Offset(, -1)
        ws2.Cells(r, "B").Resize(f, 1) = Application.Index(ar, , 1)
        r = r + f
        End If
    Next
End With
End Sub

 

[jhonty4]

Hi ombir last one works perfectly.. !! So many solutions to one problem you guys are really giving back something to the community. Cheers and thank you..

 

[Rick Rothstein]

Hi ombir last one works perfectly.. !! So many solutions to one problem you guys are really giving back something to the community. Cheers and thank you..

I was not able to get back to this thread when I woke up, but I see the thread was quite busy in my absence. And I see you have a couple of working solutions... that is good. I did want to point out that my original code would have worked for you if I had realized your Marker column was Column D and not Column A like I assumed. Anyway, just to follow up, here is my code revised for the correct columns (plus I modified it to eliminate one of the loops as well) and with the addition of the serial number in Column B on the output sheet. I believe this code should work correctly for you...

[table="width: 500"]
[tr]
	[td]Sub DistributeValuesAsEvenlyAsPossible()
  Dim X As Long, Z As Long, Rw As Long, Cnt As Long, EvenAmt As Long
  Dim WS1 As Worksheet, WS2 As Worksheet
  Set WS1 = Sheets("Sheet1")
  Set WS2 = Sheets("Sheet3")
  For X = 12 To WS1.Cells(Rows.Count, "E").End(xlUp).Row
    Cnt = Int(WS1.Cells(X, "E").Value / 100) - (Int(WS1.Cells(X, "E").Value / 100) <> WS1.Cells(X, "E").Value / 100)
    EvenAmt = Int(WS1.Cells(X, "E").Value / Cnt)
    Rw = Application.Max(31, WS2.Cells(Rows.Count, "C").End(xlUp).Row + 1)
    WS2.Cells(Rw, "C").Resize(Cnt).Value = WS1.Cells(X, "D")
    WS2.Cells(Rw, "G").Resize(Cnt).Value = EvenAmt
    For Z = 1 To WS1.Cells(X, "E").Value - Cnt * EvenAmt
      WS2.Cells(Rw + Z - 1, "G").Value = WS2.Cells(Rw + Z - 1, "G").Value + 1
    Next
    Rw = WS2.Cells(Rows.Count, "C").End(xlUp).Row - 30
    Range("B31").Resize(Rw) = Evaluate("ROW(1:" & Rw & ")")
  Next
End Sub[/td]
[/tr]
[/table]

 

[jhonty4]

Thanks a lot rick ... i should have mentioned about the position of columns in questions ,still it has been an interesting thread and i have taken a lot from it, Thank you again..