Find duplicates in column, then insert row above duplicates

[eforti]

Hello All,
I have a table of data where in column C I have values that may repeat. I'd like to find the duplicate values and insert rows above each of them using vba. Any thoughts on how to do this? I've attached an image of a sample data set where the column of peoples names have duplicates. In the table on the right this is what I'd like it to look like once the macro runs and adds rows above the duplicated values (and highlights the empty rows in black).

Please note that Ralph repeats in consecutive rows but Bob was not consecutive. It would still be a duplicate value and therefor a row would be added above Bob.

Thanks in advance for any help!

 

[Eric W]

Open a copy of your workbook. Press Alt-F11 to open the VBA editor. Press Alt-IM to Insert a Module. Paste the following code to the page that opens:

Sub InsertRows()
Dim c As Range, d As Object

    Set c = Range("B2")
    Set d = CreateObject("Scripting.Dictionary")
    
    While c <> ""
        If d.exists(c.Value) Then
            c.EntireRow.Insert
            Set c = c.Offset(1)
        End If
        d(c.Value) = 1
        Set c = c.Offset(1)
    Wend
    
End Sub

Set the value in red to the top cell in the compare column. Go back to Excel. Press Alt-F8 to open the macro selector. Choose InsertRows and click Run. Let us know if this works for you.

 

[eforti]

@Eric W , Thanks for the quick reply!

I ran this code and it did enter a row above the first duplicate but only the first duplicate of a single value. It doesn't seem to have found "all" duplicates in the column. Does the While statement result in a loop until no further duplicates are found? If not, how would I add that?

Thank you again for the speedy assistance!

 

[Eric W]

Oops! It worked on my test sheet, but I missed a few test cases. Easy fix though, just delete this line:

Set c = c.Offset(1)

the first time it appears.

 

[eforti]

@Eric W ,
I updated the code to reflect below but it still stops after a single row is inserted.

Sub InsertRows()
Dim c As Range, d As Object

    Set c = Range("C3")
    Set d = CreateObject("Scripting.Dictionary")
   
    While c <> ""
        If d.exists(c.Value) Then
            c.EntireRow.Insert
        End If
        d(c.Value) = 1
        Set c = c.Offset(1)
    Wend
   
End Sub

In looking at my data it looks like there are a couple cells in that column that are blank (and shouldn't be). So I'm wondering if I could do something like the below?

Sub InsertRows()
Dim c As Range, d As Object

    Set c = Range("C3")
' add a new range
    Set e = Range("A3")
    Set d = CreateObject("Scripting.Dictionary")
' update to reflect a different column being blank
    While e <> ""
        If d.exists(c.Value) Then
            c.EntireRow.Insert
        End If
        d(c.Value) = 1
        Set c = c.Offset(1)
    Wend
   
End Sub

I've tried this and my file runs but locks up. When I try to close the file to unfreeze it I get a debug option and close out of it. Once the debug is closed it looks like the code actually did exactly what I wanted it to with adding the rows, but I can't get it to run smoothly.

Any thoughts?

 

[Eric W]

That was my assumption, that when I hit a blank in column C, I was done. Your idea to look at another column is valid, and your code is very close!! If you put this line:

Set e = e.Offset(1)

right before the Wend, and it should work. The "Set c = c.Offset(1)" basically says "I was looking at a certain cell, but now I want to look at the cell 1 row below it." So the c value was being changed, but the e value always pointed to the same A3 cell, so it never ended.

I took a slightly different approach. Instead of looking for a blank cell, I find the last row with data in column B, and keep going until I get there.

Sub InsertRows()
Dim c As Range, d As Object

    Set c = Range("B2")
    Set c2 = Cells(Rows.Count, c.Column).End(xlUp)
    Set d = CreateObject("Scripting.Dictionary")
   
    While c.Row <= c2.Row
        If d.exists(c.Value) Then c.EntireRow.Insert
        d(c.Value) = 1
        Set c = c.Offset(1)
    Wend
   
End Sub

But I like how you're trying to figure it out yourself!

 

[eforti]

This is great @Eric W! Thank you for the help

The only piece I'm still trying to figure out is how to make the newly inserted rows highlighted black since they aren't technically selected rows. I found how to use a with selection scenario but that doesn't work.

 

[eforti]

I found the below code that I was able to call once the rest of my macro finished so I think I'm set! Thank you again for all the help @Eric W

Sub Hightlight_Black()
Application.ScreenUpdating = False
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "D").End(xlUp).Row
Dim c As Range

    For Each c In Range("D2:D" & Lastrow)
        If c.Value = "" And c.Offset(0, 1).Value = "" Then Rows(c.Row).Interior.ColorIndex = 1
    Next

Application.ScreenUpdating = True
End Sub

 

[Eric W]

I'm glad you got it working! Good luck!

 

[fakhar1212]

great