insert a blank row after each group of duplicate entries

[Matex]

Help needed!
After sorting my data, column B shows a lot of duplicate entries.

I want to write a macro that will, insert a blank row after each group of duplicate entries, this will enable me to see them more easily. I want this process to find the last active row in the worksheet then start.

 

[acw]

Hi

This should get you started.

Tony

Sub aaa()
Range("b65536").End(xlUp).Select
While ActiveCell.Row > 2
While ActiveCell = ActiveCell.Offset(-1, 0)
ActiveCell.Offset(-1, 0).Select
Wend
If ActiveCell.Row > 2 Then
ActiveCell.EntireRow.Insert
ActiveCell.Offset(-1, 0).Select
End If
Wend
End Sub

 

[erik.van.geit]

Hello, Matex,

WELCOME to the Board!

Here an alternative. It works with some "formula-tricks" to perform your operation very quickly. If there are a lot of rows, consider this code, else acw's code, which is easier to understand at first sight, will do.

kind regards,
Erik

Option Explicit

Sub insert_rows_if2()
'Erik Van Geit
'June 15 2004
Dim rng1 As Range
Dim rng2 As Range
Dim LR As Long
Application.ScreenUpdating = False
Columns(2).EntireColumn.Insert
LR = Range("C65536").End(xlUp).Row
Set rng1 = Range(Cells(2, 2), Cells(LR, 2))
Set rng2 = Range(Cells(LR + 1, 2), Cells(LR * 2, 2))
Cells(1, 2) = "header"
Cells(LR + 1, 2) = "header"
With rng1
    .FormulaR1C1 = "=IF(RC[1]=R[1]C[1],"""",COUNTIF(R1C1:R[-1]C,"">0"") +1)"
    .Copy
    .PasteSpecial xlPasteValues
    Union(Range("B1"), rng1).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Columns _
    ("A:A"), CopyToRange:=rng2, Unique:=True
End With

With rng2
    .Find("header", LookIn:=xlValues).Delete
    On Error Resume Next
    .Find("", LookIn:=xlValues).Delete
    On Error GoTo 0
    .EntireColumn.Insert
End With

LR = Range("C65536").End(xlUp).Row
With Range(Cells(2, 2), Cells(LR, 2))
    .FormulaR1C1 = "=IF(RC[1]<>"""",RC[1],R[-1]C+0.0000001)"
    .Copy
    .PasteSpecial xlPasteValues
    '.EntireColumn.Delete
    .EntireRow.Sort Key1:=[B1]
End With
Columns("B:C").Delete
Application.ScreenUpdating = True
End Sub

 

[Nimrod]

This sol'n assumes your dupes are in column "A:A" and that they are already sorted

Sub SpaceAfterDupes()
With Columns("A:A")
.Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(1), Replace:=True
Columns("A:A").SpecialCells(xlCellTypeConstants, 2).EntireRow.ClearContents
.RemoveSubtotal
Columns("A:A").Delete
End With
End Sub

 

[erik.van.geit]

Nimrod,


really very fast and ... no workaround
just using built-in functions

(I never used subtotals: great feature!)

kind regards,
Erik

 

[Nimrod]

Hello Erik
I've enjoyed many of your postings as well ... thanks for the feedback .. cheers ...

 

[Matex]

Many thanks to all, each one worked great

 

[thefile]

I love this. If I wanted to leave a subtotal SUM in columns J:AX, how would this be modified?

This sol'n assumes your dupes are in column "A:A" and that they are already sorted

Sub SpaceAfterDupes()
With Columns("A:A")
.Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(1), Replace:=True
Columns("A:A").SpecialCells(xlCellTypeConstants, 2).EntireRow.ClearContents
.RemoveSubtotal
Columns("A:A").Delete
End With
End Sub