Macro to sort then insert a row above each unique value

[duboost]

Hi,

I have a spreadsheet that constantly has data being added to it, i need a macro to sort this data by column C, then for every unique value in column C, insert a row above the first unique value and copy that unique value into column C of that newly inserted row, and do this all the way down the list till it reaches the end.

example:

A..........B...........C
Black....TV........Texas
Red......TV........New York
Blue.....Radio.....New York
Black....TV........Texas
Blue.....Radio.....New York
Red......TV........Texas

So i'd want to first sort it by C, so all New Yorks are listed together, followed by Texas. Then insert a row above the first New York and copy "New York" from the row below, into column C of the new row (in a sense inserting a header row for that group of states). Then repeat the same for Texas and so on till it reaches the end of the list.

A..........B...........C
......................New York
Red......TV........New York
Blue.....Radio.....New York
Blue.....Radio.....New York
......................Texas
Black....TV........Texas
Black....TV........Texas
Red......TV........Texas

Any help is much appreciated. Thank you

 

[MickG]

Hi, Try this:-

[COLOR="Navy"]Sub[/COLOR] MG10Aug49
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
 [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
  Rng.Resize(, 3).sort Key1:=Range("C1"), Order1:=xlAscending
[COLOR="Navy"]With[/COLOR] Range("c1")
    .EntireRow.Insert
    .Offset(-1).Value = .Value
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] Rw = Rng.count + 1 To 2 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]With[/COLOR] Range("C" & Rw)
        [COLOR="Navy"]If[/COLOR] .Value <> .Offset(-1).Value [COLOR="Navy"]Then[/COLOR]
            .EntireRow.Insert
            .Offset(-1) = .Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Rw
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[duboost]

this works great! However, i forgot to mention that I do have a header row at the top of my data in row 1. Is it possible to get this to start from the second row so it doesn't think my header row is a unique value?

Also, i'm very very new to vba, so im just trying to get an understanding of the code u wrote, if u could help me out there. Thanks a lot

Hi, Try this:-

[COLOR="Navy"]Sub[/COLOR] MG10Aug49
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
[COLOR="SeaGreen"]'sets the range to find the end of the list?[/COLOR]
 [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.count).End(xlUp))
[COLOR="SeaGreen"]'sorts column C in ascending order?[/COLOR]]
  Rng.Resize(, 3).sort Key1:=Range("C1"), Order1:=xlAscending
[COLOR="SeaGreen"]'?[/COLOR]
[COLOR="Navy"]With[/COLOR] Range("c1")
    .EntireRow.Insert
    .Offset(-1).Value = .Value
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] Rw = Rng.count + 1 To 2 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]With[/COLOR] Range("C" & Rw)
[COLOR="SeaGreen"]'If cell below is not equal to active cell, insert row above?[/COLOR]
        [COLOR="Navy"]If[/COLOR] .Value <> .Offset(-1).Value [COLOR="Navy"]Then[/COLOR]
            .EntireRow.Insert
            .Offset(-1) = .Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Rw
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[MickG]

Hi, See Modified Code and Remarks.

[COLOR="Navy"]Sub[/COLOR] MG10Aug40
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
 '[COLOR="Green"][B]sets "Rng" for all data in column "A", row 2 on[/B][/COLOR]
 [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.count).End(xlUp))
  '[COLOR="Green"][B]Resizes the Rng for 3 columns and sorts[/B][/COLOR]
  Rng.Resize(, 3).sort Key1:=Range("C2"), Order1:=xlAscending
'[COLOR="Green"][B]Loops through range from bottom to top[/B][/COLOR]
'[COLOR="Green"][B]NB:- If you loop from the top the row is inserted infront of the loop[/B][/COLOR]
'[COLOR="Green"][B] Which does not work.[/B][/COLOR]
'[COLOR="Green"][B]When adding or deleting rows always start from the Bottom[/B][/COLOR]
For Rw = Rng.count To 2 Step -1  '[COLOR="Green"][B]loop backward[/B][/COLOR]
    [COLOR="Navy"]With[/COLOR] Range("C" & Rw)
        '[COLOR="Green"][B]The "." values below refer to the "With" Range above[/B][/COLOR]
        [COLOR="Navy"]If[/COLOR] .Value <> .Offset(-1).Value [COLOR="Navy"]Then[/COLOR]
            .EntireRow.Insert
            '[COLOR="Green"][B]This offset range is one cell above the "Rw" row value[/B][/COLOR]
            .Offset(-1) = .Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Rw
'[COLOR="Green"][B]Stops screen Flashing[/B][/COLOR]
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[duboost]

Works awesome. Thanks a bunch for the code and explanation

 

[RolandKol]

Hi MickG
I am totally new in Macros,
I wonder if you would be able to help me.

I need almost the same code, just.... Macros have to:

1. Search for unique values in Column A (From Cell A2).
2. Insert row above Unique value.
3. Copy and paste this unique value in he empty row but in Column B.

example I have:
A..........B...........C
Black....TV........Texas
Red......TV........New York
Blue.....Radio.....New York
Black....TV........Texas
Blue.....Radio.....New York
Red......TV........Texas

result should be

A	B	C
	Black
Black	TV	Texas
Black	TV	Texas
	Blue
Blue	Radio	New York
Blue	Radio	New York
	Red
Red	TV	New York

<tbody>
</tbody>

 

[RolandKol]

I have solved it by amending your code:

Sub Order_By_Department()
Dim Rng As Range
Dim Dn As Range
Dim Rw As Long
Application.ScreenUpdating = False
'sets "Rng" for all data in column "A", row 2 on
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
'Resizes the Rng for 3 columns and sorts
Rng.Resize(, 3).Sort Key1:=Range("A2"), Order1:=xlAscending
'Loops through range from bottom to top
'NB:- If you loop from the top the row is inserted infront of the loop
' Which does not work.
'When adding or deleting rows always start from the Bottom
For Rw = Rng.Count To 2 Step -1 'loop backward
With Range("A" & Rw)
'The "." values below refer to the "With" Range above
If .Value <> .Offset(-1).Value Then
.EntireRow.Insert
'This offset range is one cell above the "Rw" row value
.Offset(-1, 1) = .Value
End If
End With
Next Rw
'Stops screen Flashing
Application.ScreenUpdating = True
End Sub

But I cannot understand how to make All Copied/Pasted cells BOLD and Aligned Left