PDA

View Full Version : [SOLVED] Removing duplicates from cells across rows, not down columns, without deleting rows



1819
03-04-2017, 12:23 PM
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/portfolio/excel-vba-how-to-remove-duplicates-with-vba-macro/
https://www.mrexcel.com/forum/excel-questions/689604-visual-basic-applications-remove-duplicates.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/documents/excel/1578-excel-copy-and-paste-only-non-blank-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
03-04-2017, 08:18 PM
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
03-05-2017, 10:18 AM
Excellent, thank you Leith Ross.