Как предотвратить дублирование при заполнении столбца Excel из ввода пользовательской формы?

Question

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

Я пробовал параметр проверки данных в Excel, и они работают, но когда ввод поступает от пользовательской формы, онине.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim strTargetColumn As String
    Dim nTargetRow As Integer
    Dim nLastRow As Integer
    Dim strMsg As String

    strTargetColumn = Split(Target.Address(, False), "$")(0)
    nTargetRow = Split(Target.Address(, False), "$")(1)
    nLastRow = ActiveSheet.Range(strTargetColumn & ActiveSheet.Rows.Count).End(xlUp).Row

    For nRow = 1 To nLastRow
        If nRow <> nTargetRow Then
          If ActiveSheet.Range(strTargetColumn & nRow).Value = Target.Value Then
             strMsg = "The value has been entered in the same column!"
             MsgBox strMsg, vbExclamation + vbOKOnly, "Duplicate Values"
             Target.Select
             Exit For
          End If
       End If
    Next

End Sub

Это код, который я обнаружил во время веб-поиска, который обнаруживает, что дубликат был введен в столбец, но все же позволяет ему оставаться в столбце.

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

Answer 1

Посмотрите на это в пользовательской форме. Ниже приведен способ сделать это для кнопки Geometry. Вы всегда должны использовать Option Explicit, чтобы вызвать объявление переменной;ваш код подразумевает, что вы этого не делаете. Будьте явны со своими объектами - не используйте ActiveWorkbook, ActiveCell и т. Д.

Существует множество способов улучшить это. Это не очень хороший способ сделать это. Я предоставляю это, чтобы вы пошли на лучший путь.

'@Folder("VBAProject")
Option Explicit

Private Sub GeometryAddButton_Click()
    Dim theValueToAdd As Double
    theValueToAdd = CDbl(Me.theGeometryTextbox.Text) 'assumes the value is a double
    Dim theTargetWorkbook As Workbook
    Set theTargetWorkbook = ThisWorkbook 'assumes you want to use the book the form and code are in
    Dim theTargetWorksheet As Worksheet
    Set theTargetWorksheet = theTargetWorkbook.Worksheets("myDatabaseWorksheet") 'whatever teh name of your worksheet actually is
    With theTargetWorksheet
        Dim theGeometryColumn As Long
        theGeometryColumn = 1 'assumes the Geometry column is Column A (i.e. 1)
        Dim GeometryDataRange As Range
        Set GeometryDataRange = .Range(.Cells(1, theGeometryColumn), .Cells(.UsedRange.Rows.Count, theGeometryColumn)) 'the full range of cells in Geometry column
    End With
    Dim findExistingValue As Range
    Set findExistingValue = Nothing
    On Error Resume Next 'if the value isn't found the Find method will fail, but that is what we are going to test for
        Set findExistingValue = GeometryDataRange.Find(theValueToAdd, LookIn:=xlValues, lookat:=xlWhole)
    On Error GoTo 0
    If Not findExistingValue Is Nothing Then 'if the Find does not fail (i.e. findExistingValue is not nothing)
        'pop up the message that the value already exists
    Else
        'add the value to the list
    End If
End Sub