Creating Extra Lines of Data

Sub x()
    Dim rngItem As Range
    Dim shtOut As Worksheet
    Dim rngOut As Range
    Dim rngTemp As Range
    Dim lngRow As Long
    Dim intItems As Integer
    
    Set rngItem = ActiveSheet.Range("A2", Range("A65536").End(xlUp))
    Set shtOut = ThisWorkbook.Worksheets.Add
    
    ' transfer header
    shtOut.Range("A1:B1").Value = rngItem.Offset(-1, 0).Range("A1:B1").Value
    
    Set rngOut = shtOut.Range("A2")
    For Each rngTemp In rngItem
        For intItems = 1 To (rngTemp.Offset(0, 1).Value \ 25)
            rngOut.Offset(lngRow, 0) = rngTemp.Value
            rngOut.Offset(lngRow, 1) = 25
            lngRow = lngRow + 1
        Next intItems
    Next rngTemp
    
    Set rngOut = Nothing
    Set rngItem = Nothing
    Set shtOut = Nothing
    
End Sub

Sub Divide25()
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Dim rngSrc As Range
Dim rngDst As Range
Dim LastRow As Long
Dim L As Long
Dim X As Long
Dim I As Long


    Set wsSrc = Worksheets("Sheet1")
    Set wsDst = Worksheets("Sheet2")
    
    LastRow = wsSrc.Range("A65536").End(xlUp).Row
    L = 2
        
    For I = 2 To LastRow
        Set rngSrc = wsSrc.Range("B" & I)
        Set rngDst = wsDst.Range("A" & L)
        X = rngSrc / 25
        
        rngSrc.Offset(0, -1).Copy rngDst.Resize(X, 1)
        rngDst.Offset(0, 1).Resize(X, 1) = 25
        L = L + X
    Next I
End Sub