Estoy buscando una manera de evitar que un usuario agregue una entrada duplicada en una columna de Excel. Encontré la manera de establecer la columna en Excel, pero no funciona con la entrada de formulario de usuario.

He probado la configuración de validación de datos en Excel y funcionan, pero cuando la entrada proviene del formulario de usuario no lo hacen.

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

Este es un código que encontré durante una búsqueda web que aparece que se ha introducido un duplicado en la columna, pero que todavía le permite permanecer en la columna.

Me gustaría que una ventana emergente le dijera al usuario que han agregado un duplicado, y no permitir que entre en la celda. ¿Es posible?

Userform

0
Malachilee 4 nov. 2019 a las 15:58

1 respuesta

Míralo en el evento Click del formulario de usuario para los botones. A continuación se muestra una manera de hacerlo para el botón Geometría. Siempre debe usar Option Explicit para forzar la declaración de variables; su código implica que no lo hace. Sea explícito con los objetos: no use ActiveWorkbook, ActiveCell, etc.

Hay muchas maneras de mejorar esto. No es realmente una buena manera de hacerlo. Te lo proporciono para que te pongas en una pista mejor.

'@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
0
SmileyFtW 4 nov. 2019 a las 17:16
58693933