VBA Insert Blank Rows based on Cell Value

[ceytl]

I found this VBA code, but I cannot figure out how to add more than one row.

I need to add 28 rows.

Sub InsertBlankRowsBasedOnCellValue()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "A"
StartRow = 1
BlankRows = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "7771" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True

End Sub

Thanks!

 

[My Aswer Is This]

Try this:
Note this new addition:
Resize(28)

Sub InsertBlankRowsBasedOnCellValue()
'Modified  1/3/2021  3:05:09 AM  EST
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "A"
StartRow = 1
BlankRows = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "7771" Then
.Cells(R + 1, Col).Resize(28).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True

End Sub

 

[ceytl]

Try this:
Note this new addition:
Resize(28)

Sub InsertBlankRowsBasedOnCellValue()
'Modified  1/3/2021  3:05:09 AM  EST
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long

Col = "A"
StartRow = 1
BlankRows = 1

LastRow = Cells(Rows.Count, Col).End(xlUp).Row

Application.ScreenUpdating = False

With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "7771" Then
.Cells(R + 1, Col).Resize(28).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True

End Sub

Thanks! Works perfect!

How would I change it to sheet "O" instead of active sheet?

 

[My Aswer Is This]

Try this:

Sub InsertBlankRowsBasedOnCellValue()
'Modified  1/3/2021  3:47:17 AM  EST
Application.ScreenUpdating = False
Dim Col As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "A"
StartRow = 1
LastRow = Sheets("O").Cells(Rows.Count, Col).End(xlUp).Row

With Sheets("O")
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) = "7771" Then
            .Cells(R + 1, Col).Resize(28).EntireRow.Insert Shift:=xlDown
        End If
Next R
End With
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Great to see your learning Excel.

 

[ceytl]

Try this:

Sub InsertBlankRowsBasedOnCellValue()
'Modified  1/3/2021  3:47:17 AM  EST
Application.ScreenUpdating = False
Dim Col As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "A"
StartRow = 1
LastRow = Sheets("O").Cells(Rows.Count, Col).End(xlUp).Row

With Sheets("O")
    For R = LastRow To StartRow + 1 Step -1
        If .Cells(R, Col) = "7771" Then
            .Cells(R + 1, Col).Resize(28).EntireRow.Insert Shift:=xlDown
        End If
Next R
End With
Application.ScreenUpdating = True
End Sub

Thank you!

 

[My Aswer Is This]

Thank you!

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.