VBA to Insert Rows in List

[happyhungarian]

Hi,

I have a list to names beginning in cell C9 that can vary in length. Once my list is established I need to insert 5 rows between each record in the list. I'm sure there's probably an easy way to do this but I can't figure it out.

Thank you for your help.

J

 

[Jonmo1]

Try

Sub InsertRows()
Dim lr As Long, i As Long, MyCol As String

MyCol = "A" 'Adjust to the appropriate column containing the list
lr = Cells(Rows.Count, MyCol).End(xlUp).Row

For i = lr To 3 Step -1 'Change the 3 to 2 if your list does not have a header row.
    Rows(i).Resize(5).EntireRow.Insert
Next i
End Sub

 

[happyhungarian]

Thanks. It works perfectly if the header of the list is in Row 1 but if it starts down the page a bit then it inserts a bunch of rows above the list as well as between the records. Is there a way to have it recognize that the list starts in a particular row?

 

[Jonmo1]

Try

Sub InsertRows()
Dim lr As Long, i As Long, MyCol As String
MyCol = "A" 'Adjust to the appropriate column containing the list

lr = Cells(Rows.Count, MyCol).End(xlUp).Row
fr = Columns(MyCol).Find("Header").Row + 2 'Adjust the name of the header

For i = lr To fr Step -1
    Rows(i).Resize(5).EntireRow.Insert
Next i
End Sub

 

[happyhungarian]

Worked perfectly! Thanks again.

 

[happyhungarian]

Actually had one follow-on question... is it possible to also have the macro auto-insert verbage into the new cells it creates? So for example, the first row out of the 5 it inserts it will paste the words "ID#", the second row would have "address", and so on for each of the records that were in the original list? So it would look the like following:

Header
Original list item 1
ID#
Address
etc3
etc4
etc5
Original list item 2
ID#
Address

and so on?

 

[Jonmo1]

Try

Sub InsertRows()
Dim lr As Long, fr As Long, i As Long
Dim MyCol As String, MyVals As Variant

MyCol = "A" 'Adjust to the appropriate column containing the list
MyVals = Array("ID", "Address", "Etc1", "Etc2", "Etc3")
lr = Cells(Rows.Count, MyCol).End(xlUp).Row + 1
fr = Columns(MyCol).Find("Header").Row + 2 'Adjust the name of the header

For i = lr To fr Step -1
    Rows(i).Resize(5).EntireRow.Insert
    Cells(i, MyCol).Resize(5, 1).Value = Application.Transpose(MyVals)
Next i
End Sub

 

[happyhungarian]

Worked beautifully! Thank you again.