Insert 2 blank rows after row with a specific text

[mictlantecuhtli]

Hi guys I need to insert two rows after a row with some content like this:

To this:

I haved found this code:

Sub InsertRows()
        
        Dim Rw As Long
        Dim Rng As Range
        
        Set Rng = Sheets(1).Range("A4")
        Rw = Rng.Row
        
        Do
        
            If Sheets(1).Cells(Rw + 1, 1) <> Sheets(1).Cells(Rw, 1) Then
               Sheets(1).Cells(Rw + 1, 1).EntireRow.Insert
               Rw = Rw + 2
            Else
               Rw = Rw + 1
            End If
        
        Loop While Not Sheets(1).Cells(Rw, 1) = vbNullString

End Sub

The code works great inserting only one row, but need to insert two rows.

Thank's in advanced

Grettings from México

 

[kweaver]

Your example has 1 row inserted but your statement says 2 rows. Which is it?
Do the same names cluster together always?

 

[Fluff]

How about

Sub InsertRows()
        
        Dim Rw As Long
        Dim Rng As Range
        
        Set Rng = Sheets(1).Range("A4")
        Rw = Rng.Row
        
        Do
        
            If Sheets(1).Cells(Rw + 1, 1) <> Sheets(1).Cells(Rw, 1) Then
               Sheets(1).Cells(Rw + 1, 1).Resize(2).EntireRow.Insert
               Rw = Rw + 3
            Else
               Rw = Rw + 1
            End If
        
        Loop While Not Sheets(1).Cells(Rw, 1) = vbNullString

End Sub

 

[mictlantecuhtli]

Your example has 1 row inserted but your statement says 2 rows. Which is it?
Do the same names cluster together always?

Oh my you are right dude, sorry, I need 2 rows

 

[kweaver]

This might do it:

Sub InsertRows()
'insert TWO rows above name
Dim lr As Long, i As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 4 Step -1
If Cells(i, 1) <> Cells(i - 1, 1) Then
 Cells(i, 1).Resize(2).EntireRow.Insert
Else
End If
Next i
End Sub

 

[Fluff]

Oh my you are right dude, sorry, I need 2 rows

That's what you said originally.
Did you try the mod I suggested?

 

[mictlantecuhtli]

How about

Sub InsertRows()
       
        Dim Rw As Long
        Dim Rng As Range
       
        Set Rng = Sheets(1).Range("A4")
        Rw = Rng.Row
       
        Do
       
            If Sheets(1).Cells(Rw + 1, 1) <> Sheets(1).Cells(Rw, 1) Then
               Sheets(1).Cells(Rw + 1, 1).Resize(2).EntireRow.Insert
               Rw = Rw + 3
            Else
               Rw = Rw + 1
            End If
       
        Loop While Not Sheets(1).Cells(Rw, 1) = vbNullString

End Sub

Dude thank's it works like a charm.

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[mictlantecuhtli]

Hi guys, greetings

This works great but I had a new request, the same but insert rows into a selection of cells and not into a specified range of cells

Thank´s in advanced