Macro to sort then insert a row above each unique value

duboost

New Member
Joined
Apr 8, 2010
Messages
41
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
 

Some videos you may like

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, Try this:-

Code:
[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

New Member
Joined
Apr 8, 2010
Messages
41
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:-

Code:
[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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Hi, See Modified Code and Remarks.
Code:
[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

New Member
Joined
Apr 8, 2010
Messages
41

ADVERTISEMENT

Works awesome. Thanks a bunch for the code and explanation (y)
 

RolandKol

New Member
Joined
Aug 19, 2014
Messages
14
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
ABC
Black
BlackTVTexas
BlackTVTexas
Blue
BlueRadioNew York
BlueRadioNew York
Red
RedTVNew York

<tbody>
</tbody>
 

RolandKol

New Member
Joined
Aug 19, 2014
Messages
14
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,324
Messages
5,600,956
Members
414,417
Latest member
Nobu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top