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

Question

我有一张excel表，我在不同的单元格中重复了这些值。但是这里的捕获物是所有那些细胞彼此不相邻的。我将从纸张和纸张手动中随机选择这些单元格。想要删除重复项。

在下面的屏幕截图中，我选择了值为＆＃34; test＆＃34;的随机单元格。我想从选定的单元格中删除重复项。

道歉：添加可能的方案。只需要首次出现任何重复细胞。删除剩余的事件。这意味着它应该给A1 = TEST＆amp; B6 = WEST。应删除所有其他单元格值。

Answer 1

假设您已经进行了随机选择：

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

只是为了好玩，这是一个非循环版本。它确实消灭了ActiveCell的值，然后重新分配它，这在我的有限测试中适用于所有情况：

Sub RemoveAllSelectionCellsExceptActiveCell()
Dim ActiveCellValue As Variant

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

编辑：回复您编辑过的问题

这取决于adding a duplicate to a collection generates an error的事实。如果发生这种情况，则将相关单元格添加到要删除的一系列单元格中。请注意，它会将“= 2”的单元格与具有“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

另一个......

如果你想清除细胞＆＃39;内容和格式，并将光标留在ActiveCell中，没有选中的单元格突出显示。

注意，当您进行选择时，它将是访问的最后一个单元，即ActiveCell，其内容将保留并保持选中状态。

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

此网站上应该有多个Find/FindNext个例子，但这是另一个例子。

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