Question

我正在尝试创建一个Excel文件，其中某些列具有下拉菜单，并且我会避免人们在这些列中复制和粘贴。但是，如果粘贴的值正确，则可以粘贴。

我的代码仅适用于一列。我正在尝试对每个具有不同下拉列表的多列进行操作。

在此代码示例中，仅针对两列（C和D），其下拉菜单分别位于A和B列的“下拉列表”中。

有关如何修改以下代码以使其适用于更多列的任何帮助吗？

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rng1 As Range
Dim rng2 As Range
Dim isect As Range
Dim isect2 As Range
Dim cell As Range
Dim dd() As Variant
Dim i As Long
Dim mtch As Boolean
Dim msg As String
Dim myEntries As String
Dim ddRange As Range
Dim ddRange2 As Range


Set rng1 = Range("C:C")
Set rng2 = Range("D:D")

Set ddRange = Sheets("Dropdowns").Range("A2:A11")
Set ddRange2 = Sheets("Dropdowns").Range("B2:B8")




Set isect = Intersect(rng1, Target)

Set isect2 = Intersect(rng2, Target)


If (isect Is Nothing) And (isect2 Is Nothing) Then Exit Sub

Application.EnableEvents = False



If Not isect Is Nothing Then

    ReDim dd(ddRange.Cells.Count)
    i = 0
    For Each cell In ddRange
        dd(i) = cell.Value
        i = i + 1
    Next cell


    For Each cell In isect

        mtch = False
        For i = LBound(dd) To UBound(dd)
            If cell.Value = dd(i) Then
                mtch = True
                Exit For
            End If
        Next i

        If mtch = False Then
            cell.ClearContents
            msg = msg & cell.Address(0, 0) & ","
        End If
    Next cell



    For i = LBound(dd) To UBound(dd)
        myEntries = myEntries & dd(i) & ","
    Next i
    myEntries = Left(myEntries, Len(myEntries) - 1)


    With rng1.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
            xlBetween, Formula1:=myEntries
    End With


    If Len(msg) > 0 Then
        MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
    End If
End If



If Not isect2 Is Nothing Then

    For Each cell In isect2
        If (Len(cell) > 0) And (Len(cell) <> 11) Then
            cell.ClearContents
            msg = msg & cell.Address(0, 0) & ","
        End If
    Next cell


    With rng2.Validation
        .Delete
        .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
            Operator:=xlEqual, Formula1:="11"
    End With


    If Len(msg) > 0 Then
        MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
    End If
End If

Application.EnableEvents = True

End Sub

我当时想尝试创建一个函数，并在每列中创建一个下拉菜单，以使用相应的正确下拉菜单调用该函数。

这是正确的方法吗？有什么帮助吗？

提前感谢您的时间！

Answer 1

那呢？有点脏，但确实有用。

假设您要避免人们将值粘贴到2个特定列的任何单元格中（在我的情况下，它将是C或D列的任何单元格）。为此，我使用：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 Or Target.Column = 4 Then Application.CutCopyMode = False
End Sub

因此，如果用户将一个单元格复制到剪贴板中，然后在C列或D列中选择一个单元格，则剪贴板将为空，因此他们将无法粘贴任何内容。

您可以自定义条件以进行检查并进行更严格的限制（仅特定范围，表格，一组单元格，等等）。我的例子很简单。

您可以将其与数据验证在单元格中提供的常规下拉菜单结合使用，这样它们就无法在这些单元格中粘贴任何内容。

我知道这可能看起来很脏而且很棘手，但是在我的办公室中，有些队友采用了特定形式，效果很好。

避免在不同的下拉列表Excel VBA上粘贴值

1 个答案: