列の重複するセルの内容を削除します。

Question

重複するセルの内容を1つの列で削除しようとしています。私はエントリの最初の出現を維持したいが、その下のすべての重複を削除する。

行全体を削除して内容を消去しないコードしか見つかりませんでした。

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 

私たちは私たちの上の任意の重複があるかどうかを確認するために上記チェックして、そうならば、セルをクリアします。前：

以降：

EDIT＃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

ここでは動作するルーチンがあります。必要であれば、それはかなり高速化することができます。

編集：私はあなたが「」

---

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 3

私の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 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