Insert constant number of rows, based on cell value

[Tony_Luis]

Hi all,

I'm trying to figure out a way to insert 4 rows, based on the value cells in a specific 1-column range.

For example, for all cells in column C which equal "I need help", insert 4 rows below.

Any help would be much appreciated.

Thanks!!!
Tony

 

[snjpverma]

Check if the below code helps. By the way, I am a beginner myself in VBA. So please check it in a dummy sheet first.

Sub insertrow()


Dim lr As Long
Dim rng As Range


Application.ScreenUpdating = False


Application.DisplayStatusBar = False


Application.Calculation = xlCalculationManual


Application.EnableEvents = False


lr = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row


For Each rng In Range("C1:C" & lr)
    If rng = "I need help" Then
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
    End If
        ActiveCell.Offset(1, 0).Select
Next rng


Application.ScreenUpdating = True


Application.DisplayStatusBar = True


Application.Calculation = xlCalculationAutomatic


Application.EnableEvents = True




End Sub

 

[JLGWhiz]

It is unclear if you want rows inserted or just cells within the single column. So take your choice of macros.

Sub insertRows()
Dim i As Long
With ActiveSheet
    For i = .Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
        If .Cells(i, 3) = "I need help" Then
            .Cells(i, 3).Offset(1).Resize(4).EntireRow.Insert
        End If
    Next
End With
End Sub
 
Sub insertCells()
Dim i As Long
With ActiveSheet
    For i = .Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
        If .Cells(i, 3) = "I need help" Then
            .Cells(i, 3).Offset(1).Resize(4).Insert xlShiftDown
        End If
    Next
End With
End Sub

 

[igold]

Hi Tony,

Welcome to the forum.

How about this:

Please test on a backup copy of your data.

Sub NeedHelp()


    Dim lRow As Long, i As Long
    
    Application.ScreenUpdating = False
    lRow = Cells(Rows.Count, 3).End(xlUp).Row
    For i = lRow To 2 Step -1
        If Range("C" & i).Value = "I need help" Then
            Range("C" & i + 1 & ":C" & i + 4).EntireRow.Insert
        End If
    Next
    Application.ScreenUpdating = True




End Sub

I hope this helps.

igold

 

[James006]

Another contribution ... to be tested :wink:

Sub InsertNbLines()
' Insert Nb Lines based on Condition Cell Value
Dim Rng As Range
Dim WkRng As Range
Dim LastRow As Long
Dim x As Long
Dim i As Long
Dim nb As Long
    
    nb = 4
    ' Adjust the Initial Range to your situation
    Set WkRng = Sheet1.Range("C1:C8")
    LastRow = WkRng.Rows.Count
    Application.ScreenUpdating = False
      For x = LastRow * nb To 1 Step -1
          Set Rng = Sheet1.Range("C" & x)
          If Rng.Value = "I need help" Then
                For i = 1 To nb
                Rng.Offset(i, 0).EntireRow.Insert Shift:=xlDown
                Next i
          End If
      Next x
    Application.ScreenUpdating = True
End Sub

HTH

 

[igold]

Errant post.

 

[Tony_Luis]

Thanks for the reply! The macro worked partially - it missed the first instance of the text (counting from the first row down), and where it did insert rows, it inserted them a few rows down from the text instead of right beneath.

No need for any correction as someone's posted a working solution. I appreciate the help as this is all useful learning.

Check if the below code helps. By the way, I am a beginner myself in VBA. So please check it in a dummy sheet first.

Sub insertrow()


Dim lr As Long
Dim rng As Range


Application.ScreenUpdating = False


Application.DisplayStatusBar = False


Application.Calculation = xlCalculationManual


Application.EnableEvents = False


lr = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row


For Each rng In Range("C1:C" & lr)
    If rng = "I need help" Then
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
        ActiveCell.Offset(1, 0).EntireRow.Insert
    End If
        ActiveCell.Offset(1, 0).Select
Next rng


Application.ScreenUpdating = True


Application.DisplayStatusBar = True


Application.Calculation = xlCalculationAutomatic


Application.EnableEvents = True




End Sub

 

[Tony_Luis]

The insertRows macro worked beautifully. Thanks!

 

[Tony_Luis]

This works well! Thanks!

Hi Tony,

Welcome to the forum.

How about this:

Please test on a backup copy of your data.

Sub NeedHelp()


    Dim lRow As Long, i As Long
    
    Application.ScreenUpdating = False
    lRow = Cells(Rows.Count, 3).End(xlUp).Row
    For i = lRow To 2 Step -1
        If Range("C" & i).Value = "I need help" Then
            Range("C" & i + 1 & ":C" & i + 4).EntireRow.Insert
        End If
    Next
    Application.ScreenUpdating = True




End Sub

I hope this helps.

igold

 

[Tony_Luis]

This didn't seem to work. Sorry, but I'm not sure why! A couple of solutions were posted so it's no problem. Thanks!

Another contribution ... to be tested :wink:

Sub InsertNbLines()
' Insert Nb Lines based on Condition Cell Value
Dim Rng As Range
Dim WkRng As Range
Dim LastRow As Long
Dim x As Long
Dim i As Long
Dim nb As Long
    
    nb = 4
    ' Adjust the Initial Range to your situation
    Set WkRng = Sheet1.Range("C1:C8")
    LastRow = WkRng.Rows.Count
    Application.ScreenUpdating = False
      For x = LastRow * nb To 1 Step -1
          Set Rng = Sheet1.Range("C" & x)
          If Rng.Value = "I need help" Then
                For i = 1 To nb
                Rng.Offset(i, 0).EntireRow.Insert Shift:=xlDown
                Next i
          End If
      Next x
    Application.ScreenUpdating = True
End Sub

HTH