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