How to remove duplicates for columns

Question

Edit: Realised I asked the question too Broad so I have changed the data to specify. Apologise for that. I have sample data like this:

J1_D2   J1_D3   J1_D2   J1_D2
J1_D4   J1_D7   J1_D7   
J1_D9   J1_D11  J1_13   J1_14
'
'  
'

I have no idea which row or column the data ends. The data will have Capital Letters and Underscore. The data starts at Column D but I would not have idea which column it ends. I want to remove the duplicates for the different columns on each row so it will end up like:

J1_D2   J1_D3    
J1_D4   J1_D7   
J1_D9   J1_D11  J1_13   J1_14 
'
'  
'

Update: I have tried the answers given below. It didn't remove some of the data correctly. I think it must have been because of the Capital Letters in the data

Dim r As Range, c As Range
Dim d As Object
Dim ret, i As Long

Set d = CreateObject("Scripting.Dictionary")

On Error Resume Next
Set r = Application.InputBox("Select Range", "Remove Duplicates by Row", , , 
, , , 8)
On Error GoTo 0

If Not r Is Nothing Then
For i = 0 To r.Rows.Count - 1
    For Each c In r.Offset(i).Resize(1)
        'If Not d.Exists(c.Value2) Then d.Add c.Value2, c.Value2 '~> case sensitive
        '/* below is a non-case sensitive comparison */
        If Not d.Exists(UCase(c.Value2)) Then d.Add UCase(c.Value2), c.Value2
    Next
    ret = d.Items()
    r.Offset(i).Resize(1).ClearContents
    r.Offset(i).Resize(1, UBound(ret) + 1) = ret
    d.RemoveAll
Next
End If

Answer 1

Edit: Added explanation. Best way is to step through each line by pressing F8. But first, open the locals window to see what's happening on the variables.

Try this:

'/* declarations */
Dim r As Range, c As Range
Dim d As Object
Dim ret, i As Long

'/* create and assign dictionary object which will be used in removing duplicates */
Set d = CreateObject("Scripting.Dictionary")

'/* call Input box method type 8 which accepts Range Objects and assign to variable */
On Error Resume Next '/* Needed in case invalid or no selection was made */
Set r = Application.InputBox("Select Range", "Remove Duplicates by Row", , , , , , 8)
On Error GoTo 0 '/* reset the error handling so other errors are trapped */


If Not r Is Nothing Then '/* Test if r is assigned successfully */
    For i = 0 To r.Rows.Count - 1 '/* iterate the rows of the selected range */
        For Each c In r.Offset(i).Resize(1) '/* iterate per cell of that row */
            'If Not d.Exists(c.Value2) Then d.Add c.Value2, c.Value2 '~> case sensitive
            '/* below is a non-case sensitive comparison */
            If Not d.Exists(UCase(c.Value2)) Then d.Add UCase(c.Value2), c.Value2
        '/* used dictionary object method Exists to determine duplicates */
        Next '/* repeat until all values on the target range is checked */
        ret = d.Items() '/* assign the unique items to array */
        r.Offset(i).Resize(1).ClearContents '/* clear the existing content of the target range */
        r.Offset(i).Resize(1, UBound(ret) + 1) = ret '/* assign the new contenst */
        d.RemoveAll '/* clear the existing items in dictionary object */
    Next '/* repeat the process for the next row */
End If

This will let you select the range then remove the duplicates on the selected range by row.

Answer 2

You may try something like this...

Sub RemoveDuplicates()
Dim lr As Long, lc As Long, i As Long, j As Long
Application.ScreenUpdating = False
lr = ActiveSheet.UsedRange.Rows.Count
For i = 1 To lr
    lc = Cells(i, Columns.Count).End(xlToLeft).Column
    For j = lc To 1 Step -1
        If Application.CountIf(Range(Cells(i, 1), Cells(i, lc)), Cells(i, j)) > 1 Then
            Cells(i, j).Delete shift:=xlToLeft
        End If
    Next j
Next i
Application.ScreenUpdating = True
End Sub

As per your new sample data if your data starts from column D, you need to change the code to this...

Sub RemoveDuplicates()
Dim lr As Long, lc As Long, i As Long, j As Long
Application.ScreenUpdating = False
lr = ActiveSheet.UsedRange.Rows.Count
For i = 1 To lr
    lc = Cells(i, Columns.Count).End(xlToLeft).Column
    For j = lc To 4 Step -1
        If Application.CountIf(Range(Cells(i, 1), Cells(i, lc)), Cells(i, j)) > 1 Then
            Cells(i, j).Delete shift:=xlToLeft
        End If
    Next j
Next i
Application.ScreenUpdating = True
End Sub

You can try the code in the file uploaded here...

https://www.dropbox.com/s/fqeqqrjieqizc8y/RemoveDuplicates%20v2.xlsm?dl=0

Answer 3

Your data needs to be in columns. (You may use transpose formula to do the necessary.) You can then go to data tab of Excel, click on Filter Advanced, select table range, give copy range, select Unique records and finally click okay. If necessary use transpose formula once more.

Answer 4

Find the first and last value range and use the below code

Sub RemoveDuplicatesCells()
'PURPOSE: Remove duplicate cell values within a selected cell range

Dim rng As Range
Dim x As Integer

'Optimize code execution speed
  Application.ScreenUpdating = False

'Determine range to look at from user's selection
  On Error GoTo InvalidSelection
    Set rng = Selection
  On Error GoTo 0

'Determine if multiple columns have been selected
  If rng.Columns.Count > 1 Then
    On Error GoTo InputCancel
      x = InputBox("Multiple columns were detected in your selection. " & _
        "Which column should I look at? (Number only!)", "Multiple Columns Found!", 1)
    On Error GoTo 0
  Else
    x = 1
  End If

'Optimize code execution speed
  Application.Calculation = xlCalculationManual

'Remove entire row
  rng.RemoveDuplicates Columns:=x

'Change calculation setting to Automatic
  Application.Calculation = xlCalculationAutomatic

Exit Sub

'ERROR HANDLING
InvalidSelection:
  MsgBox "You selection is not valid", vbInformation
  Exit Sub

InputCancel:

End Sub