将多个单元格复制/粘贴到 excel 列中时识别重复项

Question

所以我试图找到一个解决方案，我可以将多个值从一列复制粘贴到另一列，并让它忽略已经存在的重复项。

我找到了这段代码，但它只有在我一次复制粘贴一个值时才有效。

有没有办法让它工作，所以它只会粘贴唯一的复制值，在列中已经不存在？

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

''''''''''''''''''''''''''''''''''''''''''
'Prevents duplicate entries in Column A
''''''''''''''''''''''''''''''''''''''''''


    If Target.Cells.Count > 1 Then Exit Sub

    If Target.Column = 1 And Target <> vbNullString Then                           'Column A
        If WorksheetFunction.CountIf(Columns(1), Target) > 1 Then
            MsgBox "Entry " & Target & " already exists!", _
                vbCritical, "Dixons Travel Oslo"
            Target = ""
            Target.Select
        End If
    End If

End Sub

Answer 1

也许你觉得这很有用：

以下代码假设您只是复制所有值，即使它们已经存在。

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Column = 1 Then
    Range("A1", Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End If

End Sub

看起来像这样：

如果这适用于您的情况，请将 Header:=xlNo 更改为 Header:=xlYes。

显然，还有其他方法。我只是觉得这很容易。

Answer 2

使用与现有方法类似的方法，您可以执行以下操作：

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Application.EnableEvents = False
    For Each tcell In Target.Cells
        With tcell
        If .Column = 1 And .Value <> vbNullString Then     'Column A
            If WorksheetFunction.CountIf(Columns(1), .Value) > 1 Then
                tcell.Value = ""
            End If
        End If
        End With
    Next
    Application.EnableEvents = True
End Sub

---

这是另一种方式 - 扩展和改进 JvdV 的想法：

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target.Parent
        If Not (Intersect(Target, .Columns(1)) Is Nothing) Then
            Range("A1", Range("A" & .Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
        End If
    End With
End Sub

这允许粘贴多个单元格 - 无论有多少 列 受到影响，并且对 A 列的整个 进行重复数据删除。

Answer 3

你可以试试：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    If Target.Column = 1 Then
        Application.EnableEvents = False
            ThisWorkbook.Worksheets("Sheet1").Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
        Application.EnableEvents = True
    End If

End Sub

注意事项：

• 您可以更改工作表名称
• 标题选项