Macro - Find unique value and paste with content from column with border

[macosxguy]

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

 

[Dave Peterson]

I think that this does what you want:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim LastColToBorder As Long

Set wks = Worksheets("Sheet1")

With wks
LastColToBorder = .Range("x1").Column
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

For iRow = LastRow To FirstRow Step -1
If .Cells(iRow, "A").Value <> .Cells(iRow + 1, "A").Value Then
.Rows(iRow + 1).Resize(2, 1).EntireRow.Insert
.Cells(iRow + 1, "A").Resize(2, 1).Value _
= .Cells(iRow, "A").Value
With .Cells(iRow + 2, "A").Resize(1, LastColToBorder) _
.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End If
Next iRow
End With
End Sub

 

[Don Guillett]

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