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