Inserting a row (update)

[Tom]

I am currently using this VBA, but would like for it to insert (2) rows
instead of (1), how can I do that?

TFTH,
Tom


Sub InsertRows()

StartRow = 2 'Change the 2 to the row actual data start
DataColumn = 5 'Change the 1 to the column where your data is

i = StartRow + 1
While Cells(i, DataColumn) <> ""
If Cells(i, DataColumn) <> Cells(i - 1, DataColumn) Then
Cells(i, DataColumn).EntireRow.Insert
i = i + 1
End If
i = i + 1
Wend
End Sub

 

[Dave Peterson]

Sometimes life gets a lot easier if you start at the bottom and work your way up
to the top.

Option Explicit
Sub InsertRows()

Dim StartRow As Long
Dim DataColumn As Long
Dim LastRow As Long
Dim iRow As Long

With ActiveSheet
StartRow = 2
DataColumn = 5
LastRow = .Cells(.Rows.Count, DataColumn).End(xlUp).Row

For iRow = LastRow To StartRow Step -1
If .Cells(iRow, DataColumn).Value _
= .Cells(iRow - 1, DataColumn).Value Then
'do nothing
Else
.Rows(iRow).Resize(2).Insert
End If
Next iRow
End With
End Sub

 

[Tom]

Worked perfectly!
Thanks.

Sometimes life gets a lot easier if you start at the bottom and work your way up
to the top.

Option Explicit
Sub InsertRows()

Dim StartRow As Long
Dim DataColumn As Long
Dim LastRow As Long
Dim iRow As Long

With ActiveSheet
StartRow = 2
DataColumn = 5
LastRow = .Cells(.Rows.Count, DataColumn).End(xlUp).Row

For iRow = LastRow To StartRow Step -1
If .Cells(iRow, DataColumn).Value _
= .Cells(iRow - 1, DataColumn).Value Then
'do nothing
Else
.Rows(iRow).Resize(2).Insert
End If
Next iRow
End With
End Sub