Sub insert2rowsafteruniquenumberandformat()
Dim i As Long
Dim mc As Long
mc = 1 '"a"
On Error Resume Next
For i = Cells(Rows.Count, mc).End(xlUp).Row To 1 Step -1
If Cells(i - 1, mc) < Cells(i, mc) Then
Rows(i).Resize(2).Insert
Cells(i - 2, mc).Resize(2).Copy Cells(i, mc)
Rows(i + 1).Borders.LineStyle = xlContinuous
End If
Next i
End Sub


--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"macosxguy" <u54071@uwe wrote in message news:9abb16cbc6d68@uwe...
Hi all!
I really need help with some vba programming in excel.
My goal is following:

I do an inventory of my schools equipment and have much info in many
columns.
But I just want to concentrate on column A.

This is example of the room names at my school and look like this:

Column A
A01
A01
A02
A02
A02
A02
A02
A02
A02
A02
A04
A04
A04
A05
A05
A05
Expedition
Expedition
Expedition
Expedition
Expedition

What I want now is to find the first unique value and after the value is
found, insert two row under this value, but I also want to copy the unique
value (in the column A, not the whole row) to the new rows, have a border
(Selection.Borders(xlEdgeBottom) under the unique cell but for the whole
row
instead for only one column, so it look like this after the macro is
finished:


The requested result after the VBA script is done:

Column A
A01
A01
A01 <- New created row
A01 <- New created row, Borders(xlEdgeBottom) for the whole row
A02
A02
A02
A02
A02
A02
A02
A02
A02 <- New created row
A02 <- New created row, Borders(xlEdgeBottom) for the whole row
A04
A04
A04
A04 <- New created row
A04 <- New created row, Borders(xlEdgeBottom) for the whole row
A05
A05
A05
A05 <- New created row
A05 <- New created row, Borders(xlEdgeBottom) for the whole row
Expedition
Expedition
Expedition
Expedition
Expedition
Expedition <- New created row
Expedition <- New created row, Borders(xlEdgeBottom) for the whole row

and continue on the same way for all the other room names in Column A.

I have so far solved the problem to find the unique room names and insert
two
new rows after the unique name with a VBA script I found on some forum and
after some edititing I have the following code:

Sub Insert_Row_In_ColumnA()
Dim Number_of_rows As Long
Dim Rowinsert As Integer
Application.ScreenUpdating = False
Number_of_rows = Range("A65536").End(xlUp).Row
Rowinsert = 2
Range("A2").Select
Do Until Selection.Row = Number_of_rows + 1
If Selection.Value < Selection.Offset(-1, 0).Value Then
Selection.EntireRow.Resize(Rowinsert).Insert
Number_of_rows = Number_of_rows + Rowinsert
Selection.Offset(Rowinsert + 1, 0).Select
Else
Selection.Offset(1, 0).Select
End If
Loop
Application.ScreenUpdating = True
End Sub

Thanks for your help in advanced :-)