VBA to add a blank row between entries

[MangusColo]

First off: Windows 7 and Excel 2010

I have a massive spreadsheet and need to put a blank row after entries when the information in column T changes. Let's say the following is column T.

Blue
Blue
Blue
Red
Red
Red
Yellow

I want to insert a blank row after the 3rd Blue and 3rd Red and so on........ Below is the VBA someone gave me to try in Excel 07 and it worked perfectly. Perhaps it will help with your answer. It does not work in Excel 2010. Thank you in advance.

Please Login or Register  to view this content.

[dilipandey]

Hi Mangus,

Try below quick code:-

Please Login or Register  to view this content.

Regards,
DILIPandey

<click on below 'star' if this helps>

[MangusColo]

Ok, very good but not EXACTLY what I'm looking for. That puts a blank row after every entry. I only want a blank row after an entry if the following entry is different in column T. See Below.

Start with this:

Red
Red
Red
Red
Blue
Blue
Green
Green
Black
Yellow

I want to end up with this:

Red
Red
Red
Red

Blue
Blue

Green
Green

Black

Yellow

[dilipandey]

Hi MangusColo,

I am getting correct results when tried that macro.. do you have two columns of data ?
Please upload a sample workbook. thanks.

Regards,
DILIPandey

<click on below 'star' if this helps>

[MangusColo]

Here is a sample workbook. Column T is the column in question that I want it sorted on. Not sure I attached it correctly. Let me know.SampleMangus.xlsx

[MarvinP]

Hi guys,

I think dilipandey has his active cell in T1 and MangusColo has his active cell in A1.

@ dili - do a Cells(1,"T").Select after you select the current region and see if that corrects his problem.

hope that helps.

[dilipandey]

Hi Mangus,

Okay.. I got it, you have the data column as column T. Try using below code:-

Please Login or Register  to view this content.

Thanks MarvinP for the heads-up

Cheers

Regards,
DILIPandey

<click on below 'star' if this helps>

[Sa DQ]

Time: 0.047/2.515

Option Explicit
Dim Timer_ As Double
Sub InsertBlankRowsForArr()
 Dim Rws As Long, wW As Long, Zz As Long, Ff As Long
 
 Timer_ = Timer
 Rws = Cells(Cells.Rows.Count, "B").End(xlUp).Row
 ReDim Arr(1 To 2 * Rws)
 
 ReDim ArrT(1 To Rws + 1)
 ArrT() = Range("B1:B" & Rws + 1)
 
 Zz = Rws + 1:                          Arr(Zz) = "A0"
 For wW = 1 To Rws
    Arr(wW) = "A" & Ff
'    If Cells(wW + 1, "B").Value <> Cells(wW, "B").Value Then
    If ArrT(wW + 1, 1) <> ArrT(wW, 1) Then
    
        Zz = Zz + 1:                    Ff = Ff + 1
        Arr(Zz) = "A" & Ff & Zz
    End If
 Next wW
 Range("A1:A" & 2 * Rws).Value = WorksheetFunction.Transpose(Arr)
 
 Columns("A:B").Select
 Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False
 Columns("A:A").Select
 Selection.ClearContents
 [HH65500].End(xlUp).Offset(1).Value = Timer - Timer_
End Sub