如何删除列的重复项

编辑：实现我问这个问题太广泛，所以我已经改变了数据来指定。 为此道歉。 我有这样的样本数据：

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

我不知道数据结束哪一行或哪一列。 数据将有大写字母和下划线。 数据从D列开始，但我不知道它结束了哪一列。 我想删除每行不同列的重复项，所以最终会如下所示：

 J1_D2 J1_D3 J1_D4 J1_D7 J1_D9 J1_D11 J1_13 J1_14 ' ' ' 

更新：我已经尝试了下面给出的答案。 它没有正确删除一些数据。 我认为这一定是因为数据中的大写字母

 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

你可以尝试这样的事情…

 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 

根据你的新的样本数据，如果你的数据从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 

你可以尝试上传的文件中的代码…

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

Answer 2

编辑：添加解释。 最好的方法是按F8逐行浏览每一行。 但首先，打开本地窗口，看看variables上发生了什么。

尝试这个：

 '/* 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 

这将允许您select范围，然后按行删除所选范围内的副本。

Answer 3

find第一个和最后一个值的范围，并使用下面的代码

 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 

Answer 4

您的数据需要在列中。 （您可以使用转置公式来做必要的事情。）然后，您可以转到Excel的数据选项卡，点击filter高级，select表格范围，给出复制范围，select唯一logging，最后点击好。 如有必要，再次使用转位公式。