Insert Blank Row Beneath Based on Value USING VALUE AS NUMBER OF ROWS TO INSERT

[ChrisOK]

I located this code to help me insert blank rows beneath content but I need it to be smarter!
I want it to insert the number of rows that the cell in Col B indicates. ("4" inserts 4 rows beneath, "1" inserts 1 and so on -- until a cell in Col B is found blank, then it will stop running.

EXAMPLE
Row#....Col A.............Col B........
1..........Airplane............4..........
2..........Automobile........1..........
3..........Boat.................2..........

RESULT SHOULD LOOK LIKE THIS:
Row#....Col A.............Col B........
1..........Airplane............4..........
2.............................................
3.............................................
4.............................................
5.............................................
6..........Automobile........1..........
7.............................................
8..........Boat.................2..........
9.............................................
10............................................

THE BELOW CODE CAN BE TOTALLY THROWN OUT -
Imagine there's a much shorter method - but if not, updating it to work as desired would be great!

The below is not very automated because the user would have to keep changing the value found of "4" in the code to whatever the next value is in column B.. "1", then "2"...

Sub InsertBlankRow()
'LOCATES VALUE THEN INSERTS A SINGLE ROW UNDER THE ROW WHERE THAT VALUE IS FOUND
'NEED SOMETHING THAT WILL LOOK AT EACH VALUE FOUND IN COL B
'AND INSERT THAT NUMBER OF BLANK ROWS BENEATH THAT ROW'S VALUE
'
    Dim Rng As Range
    Dim WorkRng As Range
    On Error Resume Next
    xTitleId = "Sheet2"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    Set WorkRng = WorkRng.Columns(1)
    xLastRow = WorkRng.Rows.Count
    Application.ScreenUpdating = False
    For xRowIndex = xLastRow To 1 Step -1
        Set Rng = WorkRng.Range("A" & xRowIndex)
        If Rng.Value = "4" Then
            Rng.Offset(1, 0).EntireRow.Insert Shift:=xlDown
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[Joe4]

Try this variation instead:

Sub InsertBlankRows()

    Dim lastRow As Long
    Dim myRow As Long
    Dim bRows As Long

    Application.ScreenUpdating = False

'   Find last row in column B with data in it
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    
'   Loop through all rows backwards
    For myRow = lastRow To 1 Step -1
'       If entry in column B is numeric, insert that number of rows
        If IsNumeric(Cells(myRow, "B")) Then
            bRows = Cells(myRow, "B")
            If bRows > 0 Then
                Rows(myRow + 1 & ":" & myRow + bRows).Insert Shift:=xlDown
            End If
        End If
    Next myRow
    
    Application.ScreenUpdating = True

End Sub

 

[ChrisOK]

JOE4 -- It works perfectly!! WOW - So excited, thank you greatly! [LIKE, LIKE, LIKE!]

 

[Joe4]

You are welcome!

Glad I was able to help!

If you have any questions on any part of my code, please feel free to ask.

 

[oldbrewer]

plane

4

starting data

plane

4

boat

1

car

3

boat

1

this macro puts in the blank lines

car

3

j = 1

20 If Cells(j, 2) = "" Then GoTo 100

temp = Cells(j, 2)

For k = 1 To temp

Cells(j + k, 1).Select

Selection.EntireRow.Insert

Next k

j = j + temp + 1

GoTo 20

100 End Sub

<colgroup><col span="13"></colgroup><tbody>
</tbody>