VBA to insert rows between groups, add group header, and delete repeating values below header.

[KP_SoCal]

A while back, users Peter_SSs and Jazzed provided me some excellent feedback on how to insert a blank row after repeating cell values in a column. Click here to see the original thread.

Now I have a similar question, but it’s a little more complex. Rather than explain here, I’ll graph what I need below. Basically the Widgets are illustrated in column A, and the alpha characters (e.g. "adb") are all listed in column B.

Do any of you VBA experts have any suggestions on how I can get from my raw data to step 3 showing the expected results below?

raw data...
-----A Column----B Column
1
2---Widget1-----adb
3---Widget1-----klp
4---Widget1-----qpf
5---Widget2-----mes
6---Widget2-----xrz
7---Widget2-----uyr
8---Widget3-----dst
9---Widget3-----umn
10--Widget3-----kqh
11--Widget3-----vys

Step 1...(code starts by inserting two blank rows between groups)
-----A Column----B Column
1
2---Widget1-----adb
3---Widget1-----klp
4---Widget1-----qpf
5
6
7---Widget2-----mes
8---Widget2-----xrz
9---Widget2-----uyr
10
11
12--Widget3-----dst
13--Widget3-----umn
14--Widget3-----kqh
15--Widget3-----vys


Step 2...(code copies the first field in each group and pastes it directly above in the blank line and formats it to be bold face.)
-----A Column----B Column
1---Widget1
2---Widget1-----adb
3---Widget1-----klp
4---Widget1-----qpf
5
6---Widget2
7---Widget2-----mes
8---Widget2-----xrz
9---Widget2-----uyr
10
11---Widget3
12--Widget3-----dst
13--Widget3-----umn
14--Widget3-----kqh
15--Widget3-----vys


Step 3...(code deletes the repeating cells just below the header it just created back in step 2.)
-----A Column----B Column
1---Widget1
2-----------------adb
3-----------------klp
4-----------------qpf
5
6---Widget2
7-----------------mes
8-----------------xrz
9-----------------uyr
10
11---Widget3
12---------------dst
13---------------umn
14---------------kqh
15---------------vys


So step 3 is how the raw data would look after the code has been executed. Hope this makes sense. Thanks again for any feedback!

 

[Peter_SSs]

Building on the previous code ...

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Rearrange()<br>    <SPAN style="color:#00007F">Dim</SPAN> Aarea <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">With</SPAN> Range("A1", Range("A" & Rows.Count).End(xlUp))<br>        .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _<br>            Replace:=True, PageBreaks:=False, SummaryBelowData:=<SPAN style="color:#00007F">True</SPAN><br>        .Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents<br>        .Offset(, -1).EntireColumn.Delete<br>        .EntireColumn.RemoveSubtotal<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Aarea <SPAN style="color:#00007F">In</SPAN> Columns("A").SpecialCells(xlCellTypeConstants).Areas<br>        <SPAN style="color:#00007F">With</SPAN> Aarea<br>            <SPAN style="color:#00007F">With</SPAN> .Cells(1, 1).Offset(-1)<br>                .Value = .Offset(1).Value<br>                .Font.Bold = <SPAN style="color:#00007F">True</SPAN><br>                .EntireRow.Insert<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>            .ClearContents<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> Aarea<br>    Rows(1).Delete<br>    Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br></FONT>

 

[KP_SoCal]

Hi Peter, thank you so much for the fast reply! Sorry it has taken me so long to respond. I have been offline for a few days (crazy week).

Anyhow, I tested your code and I get a Run-time error '1004' stating "Application-defined or object-defined error". The code that it singles out as being the issue is notated below.

With .Cells(1, 1).Offset(-1)

Any ideas on how to correct this? Thanks again so much. I really, really, really appreciate it!!!

KP

 

[Peter_SSs]

Anyhow, I tested your code and I get a Run-time error '1004' stating "Application-defined or object-defined error". The code that it singles out as being the issue is notated below.

With .Cells(1, 1).Offset(-1)

Any ideas on how to correct this? Thanks again so much. I really, really, really appreciate it!!!

KP

I don't get the error. My guess is that your row 1 is not empty, even though your posted sample had row 1 empty. Could that be the problem?

 

[KP_SoCal]

I think I identified the problem. Instead of my data starting from Row A2 (as per my example), my data starts from A11. So I modified your code to reflect A10 instead of A1.

With Range("A13", Range("A" & Rows.Count).End(xlUp))

I tried running it on a sheet that had no contents above it and it ran perfectly. However, the error seems to only be firing when I have contents in cells A1-A9. It appears it has something to do with End(xlUp) in the code.

Is there anyway to program the code not to look at anything above A10 (which is my blank starting line that the first offset will be populated with). Hope this makes sense. Thanks again, you have been a tremendous help!

KP

 

[Peter_SSs]

I think I identified the problem. Instead of my data starting from Row A2 (as per my example), my data starts from A11. So I modified your code to reflect A10 instead of A1.

With Range("A13", Range("A" & Rows.Count).End(xlUp))

I tried running it on a sheet that had no contents above it and it ran perfectly. However, the error seems to only be firing when I have contents in cells A1-A9. It appears it has something to do with End(xlUp) in the code.

Is there anyway to program the code not to look at anything above A10 (which is my blank starting line that the first offset will be populated with). Hope this makes sense. Thanks again, you have been a tremendous help!

KP

Try this (it does assume there will be some data below A10)

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Rearrange()<br>    <SPAN style="color:#00007F">Dim</SPAN> Aarea <SPAN style="color:#00007F">As</SPAN> Range, Arange <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> Arange = Range("A10", Range("A" & Rows.Count).End(xlUp))<br>    <SPAN style="color:#00007F">With</SPAN> Arange<br>        .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1), _<br>            Replace:=True, PageBreaks:=False, SummaryBelowData:=<SPAN style="color:#00007F">True</SPAN><br>        .Offset(2, -1).SpecialCells(xlCellTypeConstants).Offset(, 1).ClearContents<br>        .Offset(, -1).EntireColumn.Delete<br>        .EntireColumn.RemoveSubtotal<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> Aarea <SPAN style="color:#00007F">In</SPAN> Arange.SpecialCells(xlCellTypeConstants).Areas<br>        <SPAN style="color:#00007F">With</SPAN> Aarea<br>            <SPAN style="color:#00007F">With</SPAN> .Cells(1, 1).Offset(-1)<br>                .Value = .Offset(1).Value<br>                .Font.Bold = <SPAN style="color:#00007F">True</SPAN><br>                .EntireRow.Insert<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>            .ClearContents<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> Aarea<br>    Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br><br><br></FONT>

 

[KP_SoCal]

Terrific!!!! Once again you solved it!!! Thanks again so much for your follow-up on this. Cheers!!!!



KP

 

[KP_SoCal]

Hi Peter, I have one more question concerning this outstanding block of code you supplied me. Is there a way to reverse it? I don't mean "undo", I literally mean reverse.

The reason why I'm looking to reverse it is because I'd like to import it back into an access database table after it has been reviewed in excel. If possible, that'd be great! Thanks for any suggestions.

KP

 

[Peter_SSs]

Not sure I have the row deletions exactly correct so definitely use a copy to test.

<font face=Courier New><br><SPAN style="color:#00007F">Sub</SPAN> Reverse_Rearrange()<br>    <SPAN style="color:#00007F">Dim</SPAN> bRng <SPAN style="color:#00007F">As</SPAN> Range, bArea <SPAN style="color:#00007F">As</SPAN> Range<br>    <br>    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>    <SPAN style="color:#00007F">Set</SPAN> bRng = Range("B11", Range("B" & Rows.Count).End(xlUp))<br>    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> bArea <SPAN style="color:#00007F">In</SPAN> bRng.SpecialCells(xlCellTypeConstants).Areas<br>        <SPAN style="color:#00007F">With</SPAN> bArea<br>            .Offset(, -1).Value = .Resize(1).Offset(-1, -1).Value<br>            .Resize(1).Offset(-1, -1).Clear<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Next</SPAN> bArea<br>    bRng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete<br>    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br></FONT>

 

[KP_SoCal]

Genius!!! Absolute genius!!! That worked marvelously!!!

The only small issue that I had with Sub Rearrange() is that is copies into row 10 the formatting and row height from row 9. But not the end of the world. I plugged this piece of code at the end of your code and it did the trick.

Rows("10:10").Clear
Rows("10:10").RowHeight = 15

Anyways, beautiful work!!! As always, thanks Peter for your help!

KP