如何删除列的重复项

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:

我不知道数据结束了哪一行或哪一行。数据将包含Capital Letters和Underscore。数据从D列开始,但我不知道它结束了哪一列。我想删除每行上不同列的重复项,因此它最终会像:

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

4 个解决方案

#1

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...

根据您的新样本数据,如果您的数据从D列开始,则需要将代码更改为此...

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

#2

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.

编辑:添加说明。最好的方法是按F8逐步执行每一行。但首先,打开本地窗口以查看变量上发生的情况。

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.

这将允许您选择范围,然后按行删除所选范围上的重复项。

#3

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

#4

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.

您的数据需要在列中。 (您可以使用转置公式来执行必要的操作。)然后,您可以转到Excel的数据选项卡,单击过滤器高级,选择表格范围,给出复制范围,选择唯一记录,最后单击确定。如有必要,再次使用转置公式。