View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
macosxguy macosxguy is offline
external usenet poster
 
Posts: 1
Default Macro - Find unique value and paste with content from column with border

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 :-)