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

 

[Rick Rothstein]

Using 100 maximum, what should 413 be broken out as...

82, 82, 82, 82, 85

or...

83, 83, 83, 82, 82

The first one would be easiest to calculate.

 

[Rick Rothstein]

Using 100 maximum, what should 413 be broken out as...

82, 82, 82, 82, 85

or...

83, 83, 83, 82, 82

The first one would be easiest to calculate.

Ignore the above question, I have worked out the code for both so you can choose the one you want (I am thinking you will want the second one).

Here is the code for the first situation above where the entire shortfall is loaded onto the last cell...

[table="width: 500"]
[tr]
	[td]Sub DistributeValuesEvenlyDifferenceToLastCell()
   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("Sheet2")
   For X = 12 To WS1.Cells(Rows.Count, "E").End(xlUp).Row
     Cnt = Application.RoundUp(WS1.Cells(X, "E").Value / 100, 0)
     EvenAmt = Application.RoundDown(WS1.Cells(X, "E").Value / Cnt, 0)
     Rw = Application.Max(31, WS2.Cells(Rows.Count, "A").End(xlUp).Row + 1)
     For Z = Rw To Rw + Cnt - 2
       WS2.Cells(Z, "A").Value = WS1.Cells(X, "A")
       WS2.Cells(Z, "G").Value = EvenAmt
     Next
     WS2.Cells(Z, "A").Value = WS1.Cells(X, "A")
     WS2.Cells(Z, "G").Value = WS1.Cells(X, "E").Value - (Cnt - 1) * EvenAmt
   Next
End Sub[/td]
[/tr]
[/table]

And here is the code for the second situation where the maximum difference between cells is 1 (this is the one I think you want)...

[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("Sheet2")
   For X = 12 To WS1.Cells(Rows.Count, "E").End(xlUp).Row
     Cnt = Application.RoundUp(WS1.Cells(X, "E").Value / 100, 0)
     EvenAmt = Application.RoundDown(WS1.Cells(X, "E").Value / Cnt, 0)
     Rw = Application.Max(31, WS2.Cells(Rows.Count, "A").End(xlUp).Row + 1)
     For Z = Rw To Rw + Cnt - 1
       WS2.Cells(Z, "A").Value = WS1.Cells(X, "A")
       WS2.Cells(Z, "G").Value = EvenAmt
     Next
     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
   Next
End Sub[/td]
[/tr]
[/table]

 

[jhonty4]

woah...yes i wanted the second . Thanks a lot but when i am running the code "Error : overflow pops up " what could be possibly out of place?

 

[Rick Rothstein]

woah...yes i wanted the second . Thanks a lot but when i am running the code "Error : overflow pops up " what could be possibly out of place?

I am about to go to sleep, so I'll look at it when I wake up BUT FIRST...

I need to know which line of code the error occurred on.

I also need to know if you modified what I posted in any way

 

[Ombir]

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

Try this:

Sub jhonty()
Dim i       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 = cell / maxnum + 1
            ReDim ar(1 To f)
            spnum = Application.Floor(cell / f, 1)
            j = cell Mod f
            For i = 1 To f
                If j <> 0 Then
                    ar(i) = spnum + 1
                    j = j - 1
                Else
                    ar(i) = spnum
                End If
            Next
        ws2.Cells(r, "G").Resize(f, 1) = Application.Transpose(ar)
        r = r + f
        End If
    Next
End With
End Sub

 

[jhonty4]

EvenAmt = Application.RoundDown(WS1.Cells(X, "E").Value / Cnt, 0)

this line of code produces error and i haven't made any changes to the code.

 

[jhonty4]

For Each cell In .Range("E12:E19")

hi ombir
it says variable not defined for cell. i know its a very basic error but i am not sure what data type cell is supposed to be.

 

[Peter_SSs]

Yet another option to try.

Sub Distribute()
  Dim a As Variant, b 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("E12:E19").Value
  mx = Sheets("Sheet1").Range("O6").Value
  ReDim b(1 To Rows.Count, 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) > 0 Then
      rws = (Int(a(i, 1) / mx) + IIf(a(i, 1) / mx = Int(a(i, 1) / mx), 0, 1))
      main = Int(a(i, 1) / rws)
      extra = a(i, 1) - rws * main
      For j = 1 To rws
        k = k + 1: b(k, 1) = main + IIf(j > extra, 0, 1)
      Next j
    End If
  Next i
  Sheets("Sheet2").Range("G31").Resize(k).Value = b
End Sub

 

[jhonty4]

Sub jhonty()
Dim i       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 = cell / maxnum + 1
            ReDim ar(1 To f)
            spnum = Application.Floor(cell / f, 1)
            j = cell Mod f
            For i = 1 To f
                If j <> 0 Then
                    ar(i) = spnum + 1
                    j = j - 1
                Else
                    ar(i) = spnum
                End If
            Next
        ws2.Cells(r, "G").Resize(f, 1) = Application.Transpose(ar)
        r = r + f
        End If
    Next
End With
End Sub

This works fine for all rows but it divided 658 into 83+83+82+82+82+82+82+82 whereas it should have been 94*7