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:

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:

Please Login or Register  to view this content.

Thanks for your help in advanced :-)

[Atila Akal]

If I understood correctly, you may use the macro below,

Sub InsertRows()
Application.ScreenUpdating = False
LR = Range("A65536").End(xlUp).Row
i = 1
Do Until i > LR
LR = Range("A65536").End(xlUp).Row

If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Rows(i + 1 & ":" & i + 2).Select
Selection.Insert Shift:=xlDown
Range(Cells(i + 1, 1), Cells(i + 2, 1)).Value = Cells(i, 1).Value
Rows(i + 2).Select
Selection.Borders(xlEdgeBottom).Weight = xlMedium
i = i + 2
End If
i = i + 1

Loop
[A1].select
Application.ScreenUpdating = True
End Sub

[macosxguy]

If I understood correctly, you may use the macro below,

Please Login or Register  to view this content.

Atila, This was exactly what I was after
But one thing that I want to change after I see the result and would be awesome if this could be solved. Is if you can change the script for the the border to not do the whole row, instead I only need this row to be from column A to N instead.

Otherwise the script do exactly what I was after and are very grateful for this :-)

[royUK]

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the # at the top of your post window. For more information about these and other tags, found here

[macosxguy]

Sorry royUK. I forgot to use the coding tag.
Hope this is correct coded now

[Atila Akal]

Here is the modified version;
Your are welcome

Sub InsertRows()
Application.ScreenUpdating = False
LR = Range("A65536").End(xlUp).Row
i = 1
Do Until i > LR
LR = Range("A65536").End(xlUp).Row

If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
Rows(i + 1 & ":" & i + 2).Select
Selection.Insert Shift:=xlDown
Range(Cells(i + 1, 1), Cells(i + 2, 1)).Value = Cells(i, 1).Value
Range("A" & i + 2 & ":N" & i + 2).Select
'Rows(i + 2).Select
Selection.Borders(xlEdgeBottom).Weight = xlMedium
i = i + 2
End If
i = i + 1

Loop
Application.ScreenUpdating = True
End Sub

[macosxguy]

Thanks for the modified Code Atila.
But this time after the script is finished.
Something strange happens. The border cuts the room names.
Look at this screendump:

\1

[Atila Akal]

You were so quick to test the script
I have realized the same and immediately editted the line

Range("A" & i + 2 & ":N" & i + 2).Select

Just putting +2 to i value
I believe you tested the script while I was editting the line
You can use the editted version above which editted at 04:24 Pm my time
regards

[macosxguy]

Thank you very much for the modified code Atila
The code works perfectly now...
Very great job.

But before I changed this thread to solved, I wonder one last thing to this
inventory operation.

I just wonder how I delete all rows that doesn't have any text filled (empty cell) from some of the other columns B - N?
This should be the final step after I'm finished with the inventory process and wants to clean up the rows that doesn't have any values (empty cell) in some of the columns.

Thanks really much in advanced!

[Atila Akal]

Here is the code checks B to N columns and deletes if they are empty.
You can use the macro separately (but first this one then the code above or you can copy the code beginning of the code after ""Application.ScreenUpdating = False"" line

You need to run first this code as newly created rows would be empty and would be deleted with this macro.
I hope this works

Sub DeleteRowsIf_B_N_Columns_Empty()

LR = Range("A65536").End(xlUp).Row
For i = LR To 1 Step -1

If Application.CountA(ActiveSheet.Range("B" & i & ":N" & i)) = 0 Then
Rows(i).EntireRow.Delete
End If

Next i

End Sub

[macosxguy]

Atila, You are my hero!
Thank you, thank you, thank you for this excellent programming help for all your time to help me with this.

I'm so happy and you have really saved me from many hours of extra work for this inventory operation...

Have a great day!

Kind regards