How to Delete Duplicate Column with Same Header Name

[Sherli]

Hi, I have face same issue while delete duplicate column with same header name. I have 1000 + column in my excel file and there are many duplicate column with same header name, may I know how to delete the duplicate column?

Please advise,
Sherli

 

[Fluff]

Do you want to keep the first instance of each column?
Also where are your headers?

 

[JLGWhiz]

Sub t()
Dim i As Long
    For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Application.CountIf(Rows(1), Cells(1, i).Value) > 1 Then
            Columns(i).Delete
        End If
    Next
End Sub

Test this on a copy of your file first.

 

[Sherli]

Do you want to keep the first instance of each column?
Also where are your headers?

No, I would like to remove all duplicate column. My headers at Row 1.

 

[Sherli]

Sub t()
Dim i As Long
    For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
        If Application.CountIf(Rows(1), Cells(1, i).Value) > 1 Then
            Columns(i).Delete
        End If
    Next
End Sub

Test this on a copy of your file first.

I have try this and it does not work.

 

[Fluff]

In what didn't that code work?

 

[Sherli]

In what didn't that code work?

After I run this, it do not remove all duplicate header. It still remain the 1st column of that duplicate header.

Example:
Original file:

Happy	Sad	Happy	Sad	Funny	Sad	Joy

Result I get when I run the code:

Happy	Sad	Funny	Joy

Result I want:

Funny	Joy

 

[Fluff]

Ok, how about

Sub Sherli()
   Dim Cl As Range, Rng As Range
   
   Set Rng = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            Set Rng = Union(Rng, Cl, .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.EntireColumn.Delete
End Sub

 

[JLGWhiz]

I have try this and it does not work.

For the record, the code worked as designed. It was posted before you clarified what you wanted for results.

 

[Sherli]

Ok, how about

Sub Sherli()
   Dim Cl As Range, Rng As Range
  
   Set Rng = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A1", Cells(1, Columns.Count).End(xlToLeft))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl
         Else
            Set Rng = Union(Rng, Cl, .Item(Cl.Value))
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.EntireColumn.Delete
End Sub

Thanks, Fluff. The code is work nicely.