Removing duplicate columns

Hi all,

After searching the forums I couldnt find a simple way to remove duplicates columns.
Preferrably I would like to avoid transposing my data, Is there any other way?

Regards,

found this on the internet!



Sub DeleteDuplicateColumns()
Dim rngData As Range
Dim arr1, arr2
Dim i As Integer, j As Integer, n As Integer

On Error Resume Next
Set rngData = ActiveSheet.UsedRange
If rngData Is Nothing Then Exit Sub

n = rngData.Columns.Count

For i = n To 2 Step -1
For j = i - 1 To 1 Step -1
If WorksheetFunction.CountA(rngData.Columns(i)) <> 0 And _
WorksheetFunction.CountA(rngData.Columns(j)) <> 0 Then
arr1 = rngData.Columns(i)
arr2 = rngData.Columns(j)
If AreEqualArr(arr1, arr2) Then
With rngData.Columns(j)
'mark column to be deleted
.Copy
If MsgBox("Delete marked column?", vbYesNo) _
= vbYes Then
rngData.Columns(j).Delete
Else
'remove mark
Application.CutCopyMode = False
End If
End With
End If
End If
Next j
Next i

End Sub
Function AreEqualArr(arr1, arr2) As Boolean
Dim i As Long, n As Long
AreEqualArr = False
For n = LBound(arr1) To UBound(arr1)
If arr1(n, 1) <> arr2(n, 1) Then
Exit Function
End If
Next n
AreEqualArr = True
End Function

you might also try

Sub del_dup_cols()

Dim r As Long, c As Long, i As Long, j As Long
Dim d As Object, a, x(), u

r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Set d = CreateObject("scripting.dictionary")
d.comparemode = 1
ReDim x(1 To c)
a = Cells(1).Resize(r, c)

For j = 1 To c
    u = vbNullString
    For i = 1 To r
        u = u & Chr(30) & a(i, j)
    Next i
    If Not d.exists(u) Then d(u) = 1 Else x(j) = 1
Next j

If Application.CountA(x) > 0 Then
    With Cells(r + 1, 1).Resize(, c)
        .Value = x
        .SpecialCells(xlConstants).EntireColumn.Delete
    End With
End If

End Sub