Remove duplicates across columns

[YasserKhalil]

Hello everyone
I have data in range("A1:R6") and I need to remove duplicate columns ... I have highlighted the duplicates in the attachment file
I need to eliminate columns O:R ...
Thanks advanced for help

[mana]

1)copy
2)pastespecial transpose:=true
3)removeduplicates
4)copy
5)pastespecial transpose:=true

[YasserKhalil]

Thanks a lot for reply
I have already done the same steps but I need a code as it is part of another big code ..
Thank you very much

[mdmackillop]

Sub Test()
Dim i, j
Dim Data As Range


Set Data = Cells(1, 1).CurrentRegion
For i = 1 To 18
For j = 2 To 18
If i <> j Then
If Join(Application.Transpose(Data.Columns(i).Value), "") = _
    Join(Application.Transpose(Data.Columns(j).Value), "") _
    Then Data.Columns(j).ClearContents
End If
Next j
Next i
End Sub

[YasserKhalil]

That's great and wonderful
Thank you very much for great help
Best and kind regards

[YasserKhalil]

Sorry for diturbing you again... After testing the code on the original file ( with a lot of columns) it took some time ..
Is there a way to make it faster?

[mdmackillop]

Try this to reduce the loops
For j = i + 1 To 18

[YasserKhalil]

Thanks a lot for this useful replies
This line does the trick

For j = i + 1 To 18

Best Regards

[mdmackillop]

Alternative method, should be much quicker.

Sub Test2()
    Dim Dic, i, j
    Dim data As Range
    Dim Col
    
    Set Dic = CreateObject("Scripting.Dictionary")
    Set data = Cells(1, 1).CurrentRegion
    Col = data.Columns.Count
    For i = 1 To Col
        Dic.Add i, Join(Application.Transpose(data.Columns(i)), "")
    Next
    For i = 1 To Col
        For j = i + 1 To Col
            If Dic(i) = Dic(j) Then
                data.Columns(j).ClearContents
            End If
        Next
    Next
End Sub

[YasserKhalil]

You're amazing and fascinating .. Thank you very very much for these incredible solutions