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")

[TABLE="width: 200"]
<tbody>[TR]
[TD]Shee1.Marker[/TD]
[TD]Plies[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]411[/TD]
[/TR]
[TR]
[TD]B[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD]C[/TD]
[TD]300[/TD]
[/TR]
[TR]
[TD]d[/TD]
[TD]100[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

will become
[TABLE="width: 500"]
<tbody>[TR]
[TD]Sheet2 Marker[/TD]
[TD]Plies[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]82[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]82[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]82[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]82[/TD]
[/TR]
[TR]
[TD]A[/TD]
[TD]83[/TD]
[/TR]
</tbody>[/TABLE]

..... 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]

This is perfect .. Thanks peter.. !!

 

[Peter_SSs]

This is perfect .. Thanks peter.. !!

You are welcome.

 

[Ombir]

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

There was little mistake at my end marked in Red. 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 = [COLOR=#ff0000]Application.Floor[/COLOR](cell / maxnum + 1, 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]

Hi Peter could you adjust the code so that it includes serial no (1,2,3..) in sheet2.Range(B31:B) and respective marker (A,B,C) in sheet2.Range("C31:C") as shown in the question.?

 

[Peter_SSs]

Hi Peter could you adjust the code so that it includes serial no (1,2,3..) in sheet2.Range(B31:B) and respective marker (A,B,C) in sheet2.Range("C31:C") as shown in the question.?

1. I can't see any serial no. in the question. Where are they located?

2. I can see "marker" in the question, but I don't know what column that is.

3. What columns do serial no. and marker go into in Sheet2?

 

[jhonty4]

There was little mistake at my end marked in Red. 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 = [COLOR=#ff0000]Application.Floor[/COLOR](cell / maxnum + 1, 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

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.

 

[jhonty4]

Serial number goes in column B(sheet2) and marker in column C(sheet2). i am sorry i didn't include serial number in question. i thought that be would be fairly easy once i get the breakup but all these codes are beyond my understanding .. :P

 

[Peter_SSs]

Serial number goes in column B(sheet2) and marker in column C(sheet2). i am sorry i didn't include serial number in question. i thought that be would be fairly easy once i get the breakup but all these codes are beyond my understanding .. :P

That doesn't answer my questions 1 or 2.

Where do the serial no.s come from in Sheet1? .. or are they just a new sequence 1, 2, 3, ... etc?

What column are the markers in in Sheet1?

 

[jhonty4]

That doesn't answer my questions 1 or 2.

Where do the serial no.s come from in Sheet1? .. or are they just a new sequence 1, 2, 3, ... etc?

What column are the markers in in Sheet1?

Serial number is just a new sequence and Markers is in column D of sheet 1.

 

[Peter_SSs]

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