Excel vba Crear usuario y contraseña segura

 El objetivo es poner los desarrollos que he realizado para que aprendan o me indiquen mejores formas de hacerlo.

El primero es una forma de entrar contraseña donde verifica si tiene Mayúscula, Minúscula, números, caracteres especiales y longitud adecuada.

También verifica si el usuario ya existe y si las claves si las escribió iguales.

Primero se crea el userform

El más sencillo es el botón salir:

Private Sub CommandButton1_Click()

Unload Me

End Sub

Al dar click al Botón de "Crear Usuario"

Private Sub CommandButton2_Click()

Dim Mayuscula As Integer
Dim Minuscula As Integer
Dim Numero As Integer
Dim Especial As Integer
Dim Clave As String
Dim Longitud As Integer
Dim Car As String
Dim Ascii As Integer
Dim Total As Integer
Dim usuario As String
Dim encontrado As Boolean
'Inicialiso las variables
encontrado = False
Mayuscula = 0
Minuscula = 0
Numero = 0
Especial = 0

usuario = TextBox1.Value

' Se verifica si se ha puesto algo en el usuario

    Do Until usuario <> ""
                usuario = "1"
                TextBox1.BackColor = vbYellow  'Coloca color de fondo en amarillo
                TextBox1.SetFocus
                TextBox1.Value = "<Colocar usuario>"
                usuario = TextBox1.Value
                MsgBox "Debe ingresar un usuario válido", vbExclamation
                Exit Sub
    Loop

Call BuscarUsuario(usuario, encontrado) ' Llama a Module 3, para verificar si el usuario existe 

        'Si encuentra el usuario, indica que el usuario ya existe

        If encontrado = True Then
        
            TextBox1.Value = "<Colocar usuario>"
            TextBox1.BackColor = vbYellow  'Coloca color de fondo en amarillo
            TextBox1.SetFocus
            MsgBox "El usuario ingresado ya existe, favor ingresar otro usuario", vbExclamation
            Exit Sub
        End If

                

        Clave = TextBox2.Value

        Longitud = Len(Clave)

         ' Se verifica si el password cumple con las condiciones de longitud
        ' Mayúscula, Minúscula, números y caracteres especiales

      

        If Longitud < 8 Then
            
            TextBox2.BackColor = vbYellow  'Coloca color de fondo en amarillo
            TextBox2.SetFocus
            TextBox2.Value = ""
            MsgBox "La contraseña debe tener mas de 7 caracteres!", vbExclamation
            Exit Sub
                     
        End If      'Si tiene 8 o más caracteres deja seguir

'Verifica q las dos contraseñas fueron escritas de forma correcta

        If TextBox2.Value <> TextBox3.Value Then
        
            TextBox2.BackColor = vbYellow  'Coloca color de fondo en amarillo
            TextBox2.SetFocus
            TextBox2.Value = ""
            MsgBox "Las contraseñas deben ser iguales", vbExclamation
            Exit Sub
        
        
        End If  'Si son diferentes debe volver a entrar la contraseña

'Verifica si la contraseña cumple todas las condiciones. 

 For I = 1 To Longitud
                Car = Mid(Clave, I, 1) ' toma letra por letra
                Ascii = Asc(Car)  'Convierte el carácter en número Ascii
                Select Case Ascii
                    Case 32 To 47
                        Especial = 1000
                    Case 48 To 57
                        Numero = 1
                    Case 58 To 64
                        Especial = 1000
                    Case 65 To 90
                        Mayuscula = 10
                    Case 91 To 96
                        Especial = 1000
                     Case 97 To 122
                        Minuscula = 100
                    Case 123 To 254
                        Especial = 1000
                    
                End Select
                
            Next I

                

                Total = Especial + Minuscula + Mayuscula + Numero 'Determina si todas las condiciones son correctas

            

            If  Total < 1111 Then
                            TextBox2.BackColor = vbYellow  'Coloca color de fondo en amarillo
                            TextBox2.SetFocus
                            TextBox2.Value = Empty
                            TextBox3.Value = Empty
                Select Case Total
                    Case 0
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números, Mayúscula, Minúscula y Caracteres especiales", vbExclamation
                    Case 1
                       MsgBox "La contraseña debe contener: " & vbNewLine & "Mayúscula, Minúscula y Caracteres especiales", vbExclamation
                    Case 10
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números, Minúscula y Caracteres especiales", vbExclamation
                    Case 11
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Minúscula y Caracteres especiales", vbExclamation
                    Case 100
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números, Mayúscula y Caracteres especiales", vbExclamation
                    Case 101
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Mayúscula y Caracteres especiales", vbExclamation
                    Case 110
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números y Caracteres especiales", vbExclamation
                    Case 111
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Caracteres especiales", vbExclamation
                    Case 1000
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números, Mayúscula y Minúscula", vbExclamation
                    Case 1001
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Mayúscula y Minúscula", vbExclamation
                    Case 1010
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números y Minúscula", vbExclamation
                    Case 1011
                        MsgBox "La contraseña debe contener: " & vbNewLine & " Minúscula", vbExclamation
                    Case 1100
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números y Mayúscula", vbExclamation
                    Case 1101
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Mayúscula", vbExclamation
                    Case 1110
                        MsgBox "La contraseña debe contener: " & vbNewLine & "Números", vbExclamation
                     
                    End Select
                    
                    Else
                       Call Crearusuarioc(usuario, Clave)
   
                        MsgBox "Usurario creado con Exito"
   
                        TextBox1.Value = Empty
                        TextBox2.Value = Empty
                        TextBox3.Value = Empty
                        
                        Unload Me
                End If

   

End Sub

*****************************************

Call BuscarUsuario(usuario, encontrado)

Sub BuscarUsuario(usuario, encontrado)

'

' BuscarUsuario Macro

' Busca el usuario por si ya existe

    'Definimos variables

Dim ValorBuscado As Variant, Valor As Variant, RangoBuscar As Range, loencontre As Boolean

Valor = usuario 'celda con el valor buscado

loencontre = encontrado

Set RangoBuscar = Sheets("Users").Range("A1:A232") 'rango donde buscar

ValorBuscado = Application.VLookup(Valor, RangoBuscar, 1, False) 'Lo busca en la columna 1

'Si no encuentra valor terminamos la macro y loencontre se mantiene en False

If IsError(ValorBuscado) Then  ' Si hay error es que no lo encontró

    Exit Sub

'Si lo encuentra lo devuelve

Else

'    MsgBox "El usuario ingresado ya existe, favor ingresar otro usuario", vbExclamation

    loencontre = True

    encontrado = loencontre

End If

End Sub

**********************************

Call Crearusuarioc(usuario, Clave)

Sub Crearusuarioc(usuario, Clave)

Sheets("Users").Range("A1").Select

    Selection.End(xlDown).Select 'Busca el último usuario

'pone los datos en la siguiente celda

ActiveCell.Offset(1, 0).Value = usuario

ActiveCell.Offset(1, 1).Value = Clave

End Sub