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

注意：

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

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

3 个答案: