Insert Rows Between Different Data < 2

[liam_conor]

I have a macro that loops throught all of the worksheets in a workbook and places a row inbetween all data that is different than from each other in column "A". However, it will not insert a row between data in column "A" if the different data is less than 2 in number.

Here it what I have so far:

Sub WorkshAct()
Dim ShList()
Dim ShCount As Integer
Dim x As Integer
ShCount = ActiveWorkbook.Sheets.Count
ReDim Preserve ShList(1 To ShCount)

For x = 2 To ShCount

Sheets(x).Select
InsertRows

Next x

End Sub


Sub InsertRows()
Dim iRow As Long
Dim iCount As Integer
iCount = 0

For iRow = [a65536].End(xlUp).Row - 1 To 3 Step -1

If Not IsEmpty(Cells(iRow, 1)) Then

If Cells(iRow, 1) <> Cells(iRow - 1, 1) Then

Rows(iRow).Insert

iCount = iCount + 1

End If

End If

Next iRow

End Sub

Any ideas/examples of how to do this?

 

[postandin77]

Hi Mike

Can the codes been modified t insert 3 new lines?
Thanks

I was able to modify it to do two lines by just repeating the script "Rows(i + 1).Insert"
I bet if you change it to duplicate the function 3 times you will get what you need.

Modify the script to look like this;

Sub InsertRows()
Dim r As Long, mcol As String, i As Long

' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row

' get value of last used cell in column A
mcol = Cells(r, 1).Value

' insert rows by looping from bottom
For i = r To 2 Step -1
If Cells(i, 1).Value <> mcol Then
mcol = Cells(i, 1).Value
Rows(i + 1).Insert
Rows(i + 1).Insert
Rows(i + 1).Insert
End If
Next i

End Sub

I know its spaghetti programing but it worked.