Insert Rows

[Dries]

Hi,

Could somebody help me out on the following or give me a jumpstart on how to
realize this

I have the following data

Name1 Firstname1 Member1 Number
Name1 Firstname1 Member2 Number
Name1 Firstname1 Member3 Number
Name2 Firstname2 Member4 Number
Name2 Firstname2 Member1 Number
Name3 Firstname 3 Member1 Number
Name3 Firstname 3 Member2 Number
Name3 Firstname 3 Member3 Number
Name3 Firstname 3 Member4 Number
Name3 Firstname 3 Member5 Number
Name3 Firstname 3 Member6 Number
Name3 Firstname 3 Member7 Number
Name3 Firstname 3 Member8 Number
Name3 Firstname 3 Member9 Number
Name3 Firstname 3 Member10 Number

Now the result I would like to achieve is the following:
If the Name is not reapeted 10 times with a Member a row with the Name1 and
Firstname1should be insterted until the name1 is reapted 10 times.(see name1
and name2)
If the name is already repeated 10 times or more with a member nothing
should happen
(see Name3)


So the result shoud be

Name1 Firstname1 Member1 Number
Name1 Firstname1 Member2 Number
Name1 Firstname1 Member3 Number
Name1 Firstname1
Name1 Firstname1
Name1 Firstname1
Name1 Firstname1
Name1 Firstname1
Name1 Firstname1
Name1 Firstname1
Name2 Firstname2 Member4 Number
Name2 Firstname2 Member1 Number
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name2 Firstname2
Name3 Firstname 3 Member1 Number
Name3 Firstname 3 Member2 Number
Name3 Firstname 3 Member3 Number
Name3 Firstname 3 Member4 Number
Name3 Firstname 3 Member5 Number
Name3 Firstname 3 Member6 Number
Name3 Firstname 3 Member7 Number
Name3 Firstname 3 Member8 Number
Name3 Firstname 3 Member9 Number
Name3 Firstname 3 Member10 Number

Thx for your help

 

[John Bundy]

Give this a try, assumes data is in column A

Sub main()
Dim nameCount, lastRow, i, j As Integer
'gets last row used in column A, change to suit
lastRow = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
nameCount = 1
For i = 2 To lastRow

Do Until nameCount = 10
If ActiveSheet.Cells(i - 1, 1) <> ActiveSheet.Cells(i, 1) Then
Rows(i & ":" & i).Select
Selection.Insert Shift:=xlDown
Cells(i, 1) = Cells(i - 1, 1)
End If

nameCount = nameCount + 1
i = i + 1
Loop
nameCount = 1
lastRow = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
Next

End Sub