Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 :-) |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Find a Unique code cut and paste | Excel Discussion (Misc queries) | |||
Long list, 2 criteria, find unique, paste | Excel Discussion (Misc queries) | |||
To find Multiple values in column B for a unique value in column A | Excel Worksheet Functions | |||
based on Cell/Column content ,cut one sheet's values and paste it in other sheet? | Excel Programming | |||
Macro to find text string in a column and paste data in another | Excel Discussion (Misc queries) |