Removing duplicates from cells across rows, not down columns, without deleting rows

[1819]

The small sample worksheet at the bottom has some duplicate URLs across the rows. The duplicates are coloured yellow.

I want to remove all duplicate values across the rows, keeping the remaining non-duplicate data in its rows. (Ideally, blank cells would be eliminated too, so there are still contiguous cell values across the rows).

I can find explanations about how to remove duplicate cell values entries down columns but not across rows:

http://www.bluepecantraining.com/por...ith-vba-macro/
https://www.mrexcel.com/forum/excel-...uplicates.html

There is also this code in the section "VBA code: Copy and paste only non-blank cells in Excel" on the page https://www.extendoffice.com/documen...ank-cells.html.

(Though I don't want to choose a range via dialogue box - I just simply want to remove all duplicates till the last row.)

Sub PasteNotBlanks()

Dim rng As Range
Dim InputRng As Range
Dim OutRng As Range

xTitleId = "KutoolsforExcel"
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
If InputRng.Columns.Count > 1 Then

    MsgBox "Please select one column."

    Exit Sub

End If

Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
InputRng.SpecialCells(xlCellTypeConstants).Copy Destination:=OutRng.Range("A1")
End Sub

Please could you suggest a VBA solution to remove all duplicate cell values across columns till the last row?

Many thanks.

[Leith Ross]

Hello 1819,

This macro should work for you. I have tested it on the workbook you posted. It starts at cell "A1" and determines the table rows and columns automatically.

All duplicates are removed in the row and the cells remain contiguous. Only the cell values are changed. The formatting for each cell remains unchanged.

Sub DeleteDupsInRows()


    Dim DataRow As Variant
    Dim Dict    As Object
    Dim j       As Long
    Dim k       As Long
    Dim Key     As String
    Dim lastCol As Long
    Dim lastRow As Long
    Dim Rng     As Range
    Dim Wks     As Worksheet
    
        Set Wks = ActiveSheet
        
        Set Rng = Wks.Range("A1")
        
        lastCol = Wks.Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False, False, False).Column
        lastRow = Wks.Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False, False).Row
        
        If lastRow < Rng.Row Then Exit Sub
        
        Set Rng = Rng.Resize(lastRow - Rng.Row + 1, lastCol - Rng.Column + 1)
        
         Set Dict = CreateObject("Scripting.Dictionary")
             Dict.CompareMode = vbTextCompare
            
        For j = 1 To Rng.Rows.Count
            DataRow = Rng.Rows(j).Value
            For k = 1 To UBound(DataRow, 2)
                Key = Trim(DataRow(1, k))
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, 1
                    End If
                End If
            Next k
            Rng.Rows(j).Value = Empty
            Rng.Rows(j).Resize(1, Dict.Count).Value = Dict.Keys
            Dict.RemoveAll
        Next j
        
End Sub

[1819]

Excellent, thank you Leith Ross.