使用Excel VBA从随机单元格中删除重复项

Question

I have an excel sheet where I've duplicate values in difference cells. BUT the catch here is all those cells are not adjacent to one another. I'll randomly select those cells manually from the sheets & want to remove the duplicates.

In below screenshot I've selected random cells with value "test". I would like to remove the duplicates from selected cells.

Apologies : Adding possible scenario. Need only first occurrence of any repetitive cells. Remove remaining occurrences. It means it should give A1=TEST & B6=WEST. all other cell values should be removed.

Answer 1

Assuming that you have already made the random selection:

Sub dural()
    Dim v As Variant, r As Range
    v = ActiveCell.Text
    addy = ActiveCell.Address
    For Each r In Selection
        If Not addy = r.Address Then
            If r.Value = v Then
                r.ClearContents
            End If
        End If
    Next r
End Sub

Answer 2

Just for fun, here's a non-looping version. It does wipe out the ActiveCell's value and then reassign it, which worked in all situations in my limited testing:

Sub RemoveAllSelectionCellsExceptActiveCell()
Dim ActiveCellValue As Variant

ActiveCellValue = ActiveCell.Formula
Selection.Clear
ActiveCell.Formula = ActiveCellValue
End Sub

EDIT: Response to your edited question

This relies on the fact that adding a duplicate to a collection generates an error . If that happens, the cell in question is added to a range of cells to delete. Note that it will treat a cell with "=2" as different from a cell with "2":

Sub RemoveAllSelectionCellsExceptActiveCell2()

Dim cell As Excel.Range
Dim collDupes As Collection
Dim DupeCells As Excel.Range

Set collDupes = New Collection
For Each cell In Selection.Cells
    On Error Resume Next
    collDupes.Add cell.Formula, cell.Formula
    If Err.Number <> 0 Then
        If DupeCells Is Nothing Then
            Set DupeCells = cell
        Else
            Set DupeCells = Union(DupeCells, cell)
        End If
    End If
    On Error GoTo 0
Next cell
DupeCells.Clear
End Sub

Answer 3

And another...

If you want to clear the cells' contents and formatting and leave the cursor in the ActiveCell with no selected cells highlighting.

Note, when you make your selection, it will be the last cell visited that is the ActiveCell whose contents will remain, and remain selected.

Option Explicit
Sub remSelDup()
Dim ac As Range, c As Range
Set ac = ActiveCell
    For Each c In Selection
        If c = ac And c.Address <> ac.Address Then
           c.Clear
        End If
    Next c
ac.Select
End Sub

Answer 4

There should be more than a few Find/FindNext examples on this site but here's another one.

Dim fnd As Range, fcl As Range, searchTerm As Variant

With ActiveSheet
    Set fcl = ActiveCell
    searchTerm = fcl.Value
    Set fnd = .Cells.Find(What:=searchTerm, After:=fcl, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    Do While fcl.Address <> fnd.Address
        fnd.ClearContents
        Set fnd = .Cells.FindNext(After:=fcl)
    Loop
End With