Как избежать вставки значений в разных выпадающих Excel VBA - PullRequest
0 голосов
/ 30 мая 2019

Я пытаюсь получить файл 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

Я пытался создать функцию и каждый столбец с раскрывающимся списком для вызова этой функции.с соответствующими правильными выпадающими списками.

Это правильный подход?Любая помощь в этом?

Спасибо заранее за ваше время !!

1 Ответ

0 голосов
/ 30 мая 2019

А как насчет этого?Это немного грязно, но действительно полезно.

Допустим, вы хотите избежать вставки значений людьми в любую ячейку из двух определенных столбцов (в моем случае это будет любая ячейка столбцов 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, буфер обмена будет пустым, поэтому он ничего не сможет вставить.

Вы можете настроить условия, чтобы проверить это и быть более строгими (только определенный диапазон, таблица, группа ячеек и т. Д.).Мой простой пример.

Вы можете комбинировать это с обычными раскрывающимися списками, предоставляемыми проверками данных в ячейках, поэтому они не могут ничего вставить в эти ячейки.

Я знаю, что это может выглядеть грязно и сложно, но он отлично работает в моем офисе с некоторыми товарищами по команде в определенных формах.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...