Sub Расконсолидировать()
'Выделить ячейки с количеством.
    Dim rr As Range
    Set rr = Intersect(Selection, ActiveSheet.UsedRange)
    
    Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
    
    Dim cl As Range, nn As Long
    For Each cl In Intersect(Selection, ActiveSheet.UsedRange).Cells
        If IsNumeric(cl.Value) Then
            If cl.Value > 1 Then
                nn = WorksheetFunction.RoundUp(cl.Value, 0)
                cl.EntireRow.Copy
                cl.EntireRow.Rows(2).Resize(nn - 1).Insert Shift:=xlDown
                Application.CutCopyMode = False
                cl.Cells(nn, 1).Value = cl.Value - (nn - 1)
                cl.Resize(nn - 1).Value = 1
            End If
        End If
    Next
    Application.Calculation = Application_Calculation
End Sub