Adding two blank rows between Teams

[JJanower]

Hi,

I have a big list of Persons with their repective teams, it looks somehow like this

Team1 Person1
Team1 person2
team1 person3
team1 person4
team2 person5
Team2 person6
team2 person7
team2 person8
team3 person9
team3 person10
...

The code that I' ve written inserts one row between each team but I want it to insert 2 rows or even 3, but whenever I change my code to do this, it doesn't work anymore :S. So if you have any suggestions I would be very happy.

here is my code:

[vba]Private Sub CommandButton1_Click()


Count = 2
secondcount = 2
For i = 3 To 200

'Inserting a row between teams
If Worksheets("Test").Cells(secondcount, 1) <> Worksheets("Test").Cells(secondcount + 1, 1) Then

Worksheets("Test").Rows(Count + 1 & ":" & Count + 1).Select
Selection.Insert Shift:=xlDown

With Worksheets("Test")
Worksheets("Test").range(Cells(Count, 1), Cells(Count, 1)).Select
Worksheets("Test").range(Selection, Selection.End(xlToRight)).Select
Worksheets("Test").range(Selection, Selection.End(xlUp)).Select

Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNon

End With

Count = Count + 1
secondcount = secondcount + 1

End If
Count = Count + 1
secondcount = secondcount + 1

Next

End Sub[/vba]

[mancubus]

test below code with a copy of original file.

[VBA]
Sub InsertMultipleRows()
'http://www.vbaexpress.com/forum/showthread.php?t=39564
'adopted from: http://www.mrexcel.com/forum/showthread.php?t=58685
'and http://www.ozgrid.com/forum/showthread.php?t=35463

'inserts specified number of rows at each value change in cells in column A

Dim FormatRange As Range
Dim LastRow As Long, CurRow As Long, InsRow As Long

With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With

InsRow = 2 'state the number of rows to be inserted at value change
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
RowStr = Cells(LastRow, "A").Value

For CurRow = LastRow To 2 Step -1 'assuming Row1 is header row
If UCase(Trim(Cells(CurRow, "A").Value)) <> UCase(Trim(RowStr)) Then
RowStr = UCase(Trim(Cells(CurRow, "A").Value))
Rows(CurRow + 1 & ":" & CurRow + InsRow).Insert
End If
Next CurRow

Set FormatRange = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, 23)
With FormatRange.Borders
.LineStyle = xlNone
.LineStyle = xlContinuous
.Weight = xlMedium
End With

With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub
[/VBA]