删除列中的重复单元格内容

我试图删除单个列中的重复单元格的内容。 我想保留条目的第一次出现，但删除它下面的所有重复项。

我只能find删除整行并不清除内容的代码。

Sub Duplicate() With Application ' Turn off screen updating to increase performance .ScreenUpdating = False Dim LastColumn As Integer LastColumn = Cells.Find(What:="*", After:=Range("U1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1 With Range("U1:U" & Cells(Rows.Count, 1).End(xlUp).Row) ' Use AdvanceFilter to filter unique values .AdvancedFilter Action:=xlFilterInPlace, Unique:=True .SpecialCells(xlCellTypeVisible).Offset(0, LastColumn - 1).Value = 1 On Error Resume Next ActiveSheet.ShowAllData 'Delete the blank rows Columns(LastColumn).SpecialCells(xlCellTypeBlanks).Cells.Clear Err.Clear End With Columns(LastColumn).Clear .ScreenUpdating = True End With End Sub 

Answer 1

这是一种方法。 我们从一个专栏的底部开始向上工作：

 Sub RmDups() Dim A As Range, N As Long, i As Long, wf As WorksheetFunction Dim rUP As Range Set A = Range("A:A") Set wf = Application.WorksheetFunction N = Cells(Rows.Count, "A").End(xlUp).Row For i = N To 2 Step -1 Set rUP = Range(Cells(i - 1, 1), Cells(1, 1)) If wf.CountIf(rUP, Cells(i, 1).Value) > 0 Then Cells(i, 1).Clear Next i End Sub 

我们检查上面是否有任何重复，如果是的话，清除单元格。 之前：

之后：

编辑＃1：

对于列U ：

 Sub RmDupsU() Dim U As Range, N As Long, i As Long, wf As WorksheetFunction Dim rUP As Range Set U = Range("U:U") Set wf = Application.WorksheetFunction N = Cells(Rows.Count, "U").End(xlUp).Row For i = N To 2 Step -1 Set rUP = Range(Cells(i - 1, "U"), Cells(1, "U")) If wf.CountIf(rUP, Cells(i, "U").Value) > 0 Then Cells(i, "U").Clear Next i End Sub 

Answer 2

我的0.02美分

 Sub main() Dim i As Long With Range("A1", Cells(Rows.Count, 1).End(xlUp)) For i = 1 To .Rows.Count - 1 .Range(.Cells(i + 1, 1), .Cells(.Rows.Count)).Replace what:=.Cells(i, 1).Value, replacement:="", lookat:=xlWhole Next i End With End Sub 

Answer 3

这是一个可以工作的例程。 如有必要，可以大幅加速：

编辑：我改变列号到列的字母，在那里你需要作出改变，如果你想列以外的“A”

---

 Option Explicit Sub ClearDups() Dim R As Range Dim I As Long Dim COL As Collection Set R = Range(Cells(1, "A"), Cells(Rows.Count, "A").End(xlUp)) Set COL = New Collection On Error Resume Next For I = 1 To R.Rows.Count COL.Add Item:=R(I, 1), Key:=CStr(R(I, 1)) Select Case Err.Number Case 457 'Duplicate test (Collection object rejects duplicate keys) Err.Clear R(I, 1).ClearContents Case Is <> 0 'unexpected error MsgBox Err.Number & vbLf & Err.Description End Select Next I On Error Goto 0 End Sub 

---

Answer 4

  'This code crisply does the job of clearing the duplicate values in a given column Sub jkjFindAndClearDuplicatesInGivenColumn() dupcol = Val(InputBox("Type column number")) lastrow = Cells(Rows.Count, dupcol).End(xlUp).Row For n = 1 To lastrow nval = Cells(n, dupcol) For m = n + 1 To lastrow mval = Cells(m, dupcol) If mval = nval Then Cells(m, dupcol) = "" End If Next m Next n End Sub