Deleting columns if duplicate data found in a few

[IREALLYambatman]

Goal: If a duplicate value is found in a row, then delete the second the column associated with the duplicate value
My problem: My code seems to work for the most part, except it only deletes the FIRST duplicate values that it finds, not all duplicate values. And if you run it again it seems to delete stuff almost at random?
Example Data:
[TABLE="width: 200"]
<tbody>[TR]
[TD]1
[/TD]
[TD]2
[/TD]
[TD]2
[/TD]
[TD]2
[/TD]
[TD]3
[/TD]
[TD]3
[/TD]
[TD]4
[/TD]
[TD]5
[/TD]
[TD]6
[/TD]
[TD]7
[/TD]
[/TR]
[TR]
[TD]A
[/TD]
[TD]B
[/TD]
[TD]C
[/TD]
[TD]D
[/TD]
[TD]E
[/TD]
[TD]F
[/TD]
[TD]G
[/TD]
[TD]H
[/TD]
[TD]I
[/TD]
[TD]J
[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
What I would like it to look like after:
[TABLE="width: 200"]
<tbody>[TR]
[TD]1
[/TD]
[TD]2
[/TD]
[TD]3
[/TD]
[TD]4
[/TD]
[TD]5
[/TD]
[TD]6
[/TD]
[TD]7
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]A
[/TD]
[TD]B
[/TD]
[TD]E
[/TD]
[TD]G
[/TD]
[TD]H
[/TD]
[TD]I
[/TD]
[TD]J
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

My Code:

Sub DelDuplicateDataColumns()

Dim rng As Range
Dim rngCell As Variant
Set rng = Range("C2:KZ2") ' area to check '

For Each rngCell In rng.Cells
    vVal = rngCell.Text
    If (WorksheetFunction.CountIf(rng, vVal) = 1) Then
    Else
        rngCell.EntireColumn.Delete
    End If
Next rngCell

End Sub

 

[lrobbo314]

Try this,

Sub DelCol()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


Dim r As Range: Set r = Range("C2:KZ2")
Dim AR() As Variant: AR = r.Value
Dim FC As Integer: FC = r.Cells(1, 1).Column()
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")


For i = UBound(AR, 2) To 1 Step -1
    If Not AL.contains(AR(1, i)) Then
        AL.Add AR(1, i)
    Else
        Columns(i + FC - 1).EntireColumn.Delete
    End If
Next i


Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[IREALLYambatman]

Thanks @lrobbo314 worked like a charm

 

[Peter_SSs]

Thanks @lrobbo314 worked like a charm

Perhaps it is sufficient for your needs but it does not produce the results as per your sample. The suggested code keeps the last of the duplicates (2, D and 3,F) not the first (2, B and 3, E) as in your sample.

If you want the first ones kept, and assuming your data is sorted horizontally like your sample, then try

Sub Del_Dupes()
  Dim i As Long
  
  Application.ScreenUpdating = False
  For i = 312 To 4 Step -1
    If Cells(2, i).Value = Cells(2, i - 1).Value Then Columns(i).Delete
  Next i
  Application.ScreenUpdating = True
End Sub