Break customer orders based on quantity

Sub Test()

LR = Cells(Rows.Count, 1).End(xlUp).Row

    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("D2:D" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:D" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

On Error GoTo Quit

Search:
Z = Columns(4).Find(1, LookIn:=xlValues, Lookat:=xlWhole).Row
If Z = 2 Then GoTo Quit
Q = Cells(Z - 1, 4).Value
Rows(Z & ":" & Z + Q - 2).Insert
Range(Cells(Z - 1, 1), Cells(Z - 1, 4)).Copy Destination:=Range(Cells(Z, 1), Cells(Z + Q - 2, 4))
Range(Cells(Z - 1, 4), Cells(Z + Q - 2, 4)).Value = 1
GoTo Search

Quit:

LR = Cells(Rows.Count, 1).End(xlUp).Row

    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range("A2:A" & LR) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:D" & LR)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
On Error GoTo 0
End Sub

Here you go. It's a matter of managing two loops.

Sub BreakItems()
Dim sht1 As Worksheet       ' Sheet containing the grouped items
Dim sht2 As Worksheet       ' Sheet containing the broken out items
Dim LRow1 As Long           ' Last row on sheet 1
Dim RowNum2 As Long         ' Working row number sheet 2
Dim i1 As Long              ' Row index on sheet 1
Dim i2 As Long              ' Row index on sheet 2

Dim Item As String          ' Item
Dim Customer As String      ' Customer
Dim DueDate As Date         ' Due Date
Dim Qty As Long             ' Quantity

' Initalize variables
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
RowNum2 = 2

' Clear old data
sht2.Cells.ClearContents

' Make titles
sht2.Range("A1") = "Item"
sht2.Range("B1") = "Customer"
sht2.Range("C1") = "Due Date"

' get the last row on sheet 1
LRow1 = sht1.Range("A" & Rows.Count).End(xlUp).Row

' Loop through the items and
For i1 = 4 To LRow1
    Item = sht1.Cells(i1, "A")           ' Item
    Customer = sht1.Cells(i1, "B")       ' Customer
    DueDate = sht1.Cells(i1, "C")        ' Due Date
    Qty = sht1.Cells(i1, "D")            ' Quantity
    
    ' Loop thorugh sheet 2
    For i2 = RowNum2 To RowNum2 + Qty - 1
        sht2.Cells(i2, "A") = Item
        sht2.Cells(i2, "B") = Customer
        sht2.Cells(i2, "C") = DueDate
    Next i2
    RowNum2 = RowNum2 + Qty
Next i1

End Sub