View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Dave Peterson Dave Peterson is offline
external usenet poster
 
Posts: 35,218
Default Macro - Find unique value and paste with content from column withborder

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


macosxguy wrote:

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