Delete entire column with duplicates in row 2

[emccracken]

I'm looking to delete duplicate columns based on the value in row 2. I have code that accomplishes this, but it deletes both the duplicate and the original. I need to keep one of the values. Here's what I have:

Option Explicit


Sub Row2Dups()


Dim rRow2 As Range
Dim aryRow2() As Long
Dim i As Long


    With ActiveSheet
        Set rRow2 = Range(.Cells(2, 1), .Cells(2, .Columns.Count).End(xlToLeft))
    End With
    
ReDim aryRow2(1 To rRow2.Columns.Count)


    For i = LBound(aryRow2) To UBound(aryRow2)
        aryRow2(i) = Application.WorksheetFunction.CountIf(rRow2, rRow2.Cells(1, i).Value)
    Next i
    
    For i = UBound(aryRow2) To LBound(aryRow2) Step -1
        If aryRow2(i) > 1 Then rRow2.Columns(i).EntireColumn.Delete
    Next i


End Sub

I have attached a sample file. The columns highlighted in blue are the duplicates. I need to delete ONE set of duplicates, and if you run my code, you'll see it deletes both.

[Paul_Hossler]

Try this version

Option Explicit

Sub Row2Dups()
    Dim rRow2 As Range, rStart As Range, rEnd As Range
    Application.ScreenUpdating = False
    With ActiveSheet
        Set rStart = .Cells(2, 3)
        Set rEnd = .Cells(2, .Columns.Count).End(xlToLeft)
    
        Do While rStart.Address <> rEnd.Address
            
            Range(rStart.Offset(0, 1), rEnd).Replace rStart.Value, True, xlWhole
        
            Set rStart = rStart.Offset(0, 1)
        Loop
        
        On Error Resume Next
        Range(.Cells(2, 3), .Cells(2, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants, xlLogical).EntireColumn.Delete
        On Error GoTo 0
    
    End With
    
    Application.ScreenUpdating = True
    
End Sub

[emccracken]

That worked on my sample. I'll let you know if it works on the real file tomorrow. Thanks!

[Paul_Hossler]

there's a few minor performance tweaks that might help if you have a gazillion columns, but the increase in complexity didn't seem worth it for reasonable amounts of data

[emccracken]

It worked, it just didn't grab the entire range I wanted. I don't understand your code, so I tweaked it to this and it seems to work:

Sub Row2Dups()


    Dim rRow2 As Range, rStart As Range, rEnd As Range


    Application.ScreenUpdating = False


    With ActiveSheet
        Set rStart = .Cells(2, 2)
        Set rEnd = .Cells(2, .Columns.Count).End(xlToLeft)
    
        Do While rStart.Address <> rEnd.Address
            
            Range(rStart.Offset(0, 1), rEnd).Replace rStart.Value, True, xlWhole
        
            Set rStart = rStart.Offset(0, 1)
        Loop
        
        On Error Resume Next
        Range(.Cells(2, 2), .Cells(2, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants, xlLogical).EntireColumn.Delete
        On Error GoTo 0
    
    End With
    
    Application.ScreenUpdating = True
    


End Sub

So basically I just changed your 3's to 2's and it seems to work. My sample was probably a few cells off.

[Paul_Hossler]

I think your sample started in C2, hence Cells (2,3)

It could be made more general purpose and a tad faster if you want to

[emccracken]

I think this should work. How far does this code run? If I have duplicates in columns Z and AA, will it catch them? If no, how could I edit this to make it work that way?

[Paul_Hossler]

This starts in B2 and ends by starting from XFD2 and going to the left until the first non-empty cell

        Range(.Cells(2, 2), .Cells(2, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants, xlLogical).EntireColumn.Delete