Remove duplicate values in a range by rows not columns

Question

I'm trying to remove duplicate values in columns in a range. For example, I have the following table (yes, looks like a transposed table):

How to remove the duplicate columns in the range B1:F3? The desired output will be like this one:

I tried the following piece of code but it's not working:

ActiveSheet.Range("$B$1:$F$3").RemoveDuplicates Columns:=Array(2, 3, 4, 5, 6), Header:=xlNo

I get a run-time error: Application-defined or object-defined error.

Answer 1

You don't have 6 columns in your range. Column indexes are relative, not column numbers in a sheet.

ActiveSheet.Range("$B$1:$F$3").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), _
        Header:=xlNo

Besides, from the very beginning with VBA, avoid using ActiveSheet.

Answer 2

Edited after OP's request

and here's my 0.02 cents

Option Explicit

Sub main()
    Dim myRange As Range, cell As Range

    Set myRange = Range("$B$1:$F$1")
    With CreateObject("Scripting.Dictionary")
        For Each cell In myRange
            .Item(Join(Application.Transpose(cell.Resize(3).Value), "|")) = cell.EntireColumn.Address
        Next
        Intersect(myRange, Range(Join(.items, ","))).EntireColumn.Hidden = True
    End With

    With myRange.Resize(3) 
        .SpecialCells(xlCellTypeVisible).Delete
        .EntireColumn.Hidden = False
    End With

End Sub

it uses a Dictionary to collect "unique" columns label as keys and corresponding column index as items

then it hides "unique" columns, deletes visible (i.e. "duplicated") ones and finally makes all remaining (i.e. "unique") columns visible

Answer 3

You could do it fairly easily with a couple of for loops, something like:

' number of columns
COL = 7

' for each column
for x = 2 to (COL-1)
    ' check subsequent columns
    for y = x+1 to COL
        'if they are the same delete the second one
        if cells(1,x) = cells(1,y) and cells(2,x) = cells(2,y) and cells(3,x) = cells(3,y) then
            columns(y).delete
        end if
    next y
next x

Answer 4

The following will transpose your data then remove duplicates and then paste over your original data without duplicates:

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Lastcol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
ws.Range("A1:F" & LastRow).Copy
ws.Range("A" & LastRow + 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
ws.Range("$A$" & LastRow + 1 & ":$C$" & (LastRow + 1 + Lastcol)).RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlYes
ws.Range("$A$" & LastRow + 1 & ":$C$" & (LastRow + 1 + Lastcol)).Copy
ws.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
ws.Range("$A$" & LastRow + 1 & ":$C$" & (LastRow + 1 + Lastcol)).ClearContents
End Sub

Answer 5

Here is another Remove Duplicates by Column.

Option Explicit

Sub nmrewq()
    Dim i As Long

    With Worksheets("sheet13")
        With .Range("B1:F3")
            For i = .Columns.Count To 2 Step -1
                If Application.CountIfs(.Cells(1, 1).Resize(1, i), .Cells(1, i), _
                                        .Cells(2, 1).Resize(1, i), .Cells(2, i), _
                                        .Cells(3, 1).Resize(1, i), .Cells(3, i)) > 1 Then
                    .Cells(1, i).EntireColumn.Delete
                End If
            Next i
        End With
    End With
End Sub

Answer 6

One more answer won't do harm. This code shall remove not welcomed columns as well.

Sub RemoveDupCols()
    Dim rng As Range
    Dim cl As Range
    Set rng = Range("B:F")
    For Each cl In Intersect(rng, ActiveSheet.Range("1:1"))
        Do While TypeName(Range(cl.Offset(, 1), rng.Range("F1")).Find(cl.Value)) <> "Nothing"
           Debug.Print Range(cl.Offset(, 1), rng.Range("F1")).Find(cl.Value).Delete
        Loop
    Next
End Sub