macro to create rows of data based on divided quantities

I need a code that will take the amount I have on order for a certain day, divide it by the amount in a container and create a line item for each of the divisable amounts plus the remainder. For example: I have 250 (cell F21) on order for 11/28 (cell B21) and 100 qty per container (cell P3). The results should be

Column P Column Q
11/28 100
11/28 100
11/28 50

Thank you.

Put this into a regular code module (Insert > Module):

Option Explicit

Sub FillContainers()
Dim RNG As Range, cel As Range
Dim CntMax As Long, Cnt As Long, NR As Long

On Error Resume Next
Set RNG = Range("F8:F60").SpecialCells(xlConstants, xlNumbers)

If Not RNG Is Nothing Then
    CntMax = [P3]
    NR = Range("P" & Rows.Count).End(xlUp).Row + 1
    If NR < 8 Then NR = 8
    
    For Each cel In RNG
        Cnt = cel
        Do
            Range("P" & NR).Value = Range("B" & cel.Row)
            
            If Cnt > CntMax Then
                Range("Q" & NR).Value = CntMax
                Cnt = Cnt - CntMax
                NR = NR + 1
            Else
                Range("Q" & NR).Value = Cnt
                NR = NR + 1
                Exit Do
            End If
        
        Loop
    Next cel
End If

End Sub

Hello MSapprentice,

Here is another solution with additional flexibility. This macro will allow you to have the container amount list on another sheet. The macro also sizes the table dynamically so you won't have to modify the macro when adding or deleting rows. The attached workbook has the macro added.

' Thread:  http://www.excelforum.com/excel-programming/789177-macro-to-create-rows-of-data-based-on-divided-quantities.html
' Poster:  MSApprentice
' Written: August 22, 2011
' Author:  Leith Ross

Sub POBreakdown()

  Dim Amount As Double
  Dim Cell As Range
  Dim DstRng As Range
  Dim NextRow As Long
  Dim RngEnd As Range
  Dim SrcRng As Range
  Dim SrcWks As Worksheet
    
  ' Assign the Source and Destination worksheets
    Set SrcWks = Worksheets("OH")
    Set DstWks = Worksheets("OH")
    
  ' Assign the Source And Destination starting cells
    Set SrcRng = SrcWks.Range("F8")
    Set DstRng = DstWks.Range("P8")
    
    ' Use column "E" to find the bottom of the table since column "F" has "Total" lines
      Set RngEnd = SrcWks.Cells(Rows.Count, SrcRng.Column - 1).End(xlUp).Offset(0, 1)
      
    ' Set the source range's full range
      Set SrcRng = IIf(RngEnd.Row < SrcRng.Row, SrcRng, SrcWks.Range(SrcRng, RngEnd))
      
    ' Find the last entry in the destination range and set the destination's full range
      Set RngEnd = DstWks.Cells(Rows.Count, DstRng.Column).End(xlUp)
      Set DstRng = IIf(RngEnd.Row < DstRng.Row, DstRng, DstWks.Range(DstRng, RngEnd))
      
      ' Container amount
        Amount = SrcWks.Range("P3")
        
      ' Clear the destination columns "P" and "Q"
        DstRng.Resize(ColumnSize:=2).ClearContents
        Set DstRng = DstRng.Cells(1, 1)
        
        For Each Cell In SrcRng
          If Cell <> "" Then
             For I = 1 To Cell \ Amount
               DstRng.Offset(NextRow, 0) = Cell.Offset(0, -4)   'Date
               DstRng.Offset(NextRow, 1) = Amount               'Amount evenly divisible
               NextRow = NextRow + 1
             Next I
             
           ' Is there anything remaining?
             If Cell Mod Amount <> 0 Then
                DstRng.Offset(NextRow, 0) = Cell.Offset(0, -4)  'Date
                DstRng.Offset(NextRow, 1) = Cell Mod Amount     'Remaining amount
                NextRow = NextRow + 1
             End If
          End If
        Next Cell
        
End Sub