CODEWITHSUNDEEP
vbaexcelduplicates
Peter_07
Peter_07

Reputation: 117

Remove duplicate values in a range by rows not columns

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):

enter image description here

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

enter image description here

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.

Upvotes: 1

Views: 2175

Answers (6)

DisplayName
DisplayName

Reputation: 13386

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

Upvotes: 1

MarcinSzaleniec
MarcinSzaleniec

Reputation: 2256

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

Upvotes: 1

user4039065
user4039065

Reputation:

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

Upvotes: 1

Xabier
Xabier

Reputation: 7735

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

Upvotes: 1

Jerome Paddick
Jerome Paddick

Reputation: 449

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

Upvotes: 1

brainac
brainac

Reputation: 410

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.

Upvotes: 2

Related Questions