VBA to split/copy rows based on max quantities

Hello

Welcome to the Forum!

The following macro has been added to your workbook. There is button on the sheet to run it.

Sub Macro1()

    Dim Data    As Variant
    Dim MaxCnt  As Long
    Dim n       As Long
    Dim r       As Long
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim rowcnt  As Long
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set RngBeg = Wks.Cells.Find("Qty", , xlValues, xlWhole, xlByColumns, xlNext, False, False, False)
            If RngBeg Is Nothing Then
                MsgBox "Quantity column not found.", vbExclamation
                Exit Sub
            End If
        
        Set Rng = RngBeg.CurrentRegion
            If Rng.Rows.Count = 1 Then
                MsgBox "There is data in the table.", vbExclamation
                Exit Sub
            End If
            
            Set Rng = Intersect(Rng, Rng.Offset(1, 0))
            
            Data = Rng.Value
            
            For n = LBound(Data, 1) To UBound(Data, 1)
            
                Select Case LCase(Data(n, 3))
                    Case Is = "small": MaxCnt = 10
                    Case Is = "large": MaxCnt = 5
                    Case Else: MaxCnt = 1
                End Select
                
                If MaxCnt > 1 Then
                    rowcnt = (Data(n, 1) \ MaxCnt)
                    r = (Data(n, 1) Mod MaxCnt)
                    If r > 0 Then rowcnt = rowcnt + 1
                Else
                    rowcnt = rowcnt + 1
                End If
                
                Data(n, 1) = MaxCnt
                
                Set Rng = Rng.Resize(RowSize:=rowcnt)
                Rng.Value = Application.Index(Data, n, 0)
                
                If r <> 0 Then Rng.Cells(Rng.Rows.Count, 1) = r
                
                Set Rng = Rng.Offset(rowcnt, 0)
                
            Next n
            
End Sub