Const Sym As String = "/\!·$%&/()='""¡¿?<>., :;-_*+" 'Simbolos
Const Num As String = "0123456789"                   'Numeros
Const Min As String = "abcdefghijklmnopqrstuvwxyz"   'Letras Minusculas
Const May As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"   'Letras Mayusculas
Const SpL As String = "áéíóúàèìòùâêîôûäëïöüçñ"       'Letras Especiales Minusculas
Const SpU As String = "ÁÉÍÓÚÀÈÌÒÙÊÎÔÛÄËÏÖÜÇÑ"       'Letras Especiales Mayusculas
Dim Cad As String                                    'Cadena entera de caracteres
Dim X As Long                                        'Para los Bucles

Private Sub Inicio()
Dim Letras() As String
Dim Posiciones() As Long
Dim Palabras() As String
Dim a As Long
Dim CT As Long
Dim CantPos As Long
Dim CantLet As Long
    Letras = CharSplit7913(Cad)
    CantLet = UBound(Letras)
    Open "C:\Dic7913.txt" For Output As #1
    Close #1
    ReDim Palabras(1000)
    For a = 0 To Val(MinMaxL(1).Text) - Val(MinMaxL(0).Text)
        CantPos = MinMaxL(0) + a - 1
        ReDim Posiciones(CantPos)
        Do
        For X = 0 To CantPos
            Palabras(CT) = Palabras(CT) & Letras(Posiciones(X))
        Next
        CT = CT + 1
        Posiciones(0) = Posiciones(0) + 1
        For X = 0 To CantPos - 1
            If Posiciones(X) > CantLet Then Posiciones(X) = 0: Posiciones(X + 1) = Posiciones(X + 1) + 1
        Next
        If CT = 1001 Then
            Open "C:\Dic7913.txt" For Append As #1
                For X = 0 To 1000
                    Print #1, Palabras(X)
                Next
            Close #1
            ReDim Palabras(1000)
            CT = 0
        End If
        If Posiciones(CantPos) = CantLet + 1 Then GoTo Terminado
        Loop
Terminado:
    Next
    If CT <> 0 Then
        Open "C:\Dic7913.txt" For Append As #1
            For X = 0 To CT
                Print #1, Palabras(X)
            Next
        Close #1
        CT = 0
    End If
    MsgBox "Terminado", vbInformation, "Atencion"
End Sub

Private Sub Caracteres_Click(Index As Integer)
    'Limita el checkbox de los caracteres extra si el cuadro de texto esta vacio
    If Index = 6 And Len(ExtraCHR.Text) = 0 Then Caracteres(6).Value = 0: MsgBox "El cuadro de texto de caracteres extra debe tener al menos un caracter", vbCritical, "Error"
End Sub

Private Sub Go_Click()
Dim FlagCheck As Boolean
    'Comprobacion de los minimos y maximos de longitud
    If Val(MinMaxL(0).Text) = 0 Then MsgBox "El minimo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
    If Val(MinMaxL(1).Text) = 0 Then MsgBox "El maximo de longitud no puede ser cero", vbCritical, "Error": Exit Sub
    If Val(MinMaxL(0).Text) - Val(MinMaxL(1).Text) > 0 Then MsgBox "El maximo de longitud no puede ser menor que el minimo", vbCritical, "Error": Exit Sub
    'Comprobacion de los checkboxes, minimo uno debe estar tildado
    For X = 0 To 6
        If Caracteres(X).Value = 1 Then FlagCheck = True
    Next
    If FlagCheck = False Then MsgBox "Seleccione primero con que caracteres quiere hacer el diccionario", vbCritical, "Error": Exit Sub
    Cad = vbNullString 'Vacio el string Cad por si estaba lleno
    'Lleno cad con la seleccion del usuario
    If Caracteres(0).Value = 1 Then Cad = Num
    If Caracteres(1).Value = 1 Then Cad = Cad & Sym
    If Caracteres(2).Value = 1 Then Cad = Cad & Min
    If Caracteres(3).Value = 1 Then Cad = Cad & Max
    If Caracteres(4).Value = 1 Then Cad = Cad & SpL
    If Caracteres(5).Value = 1 Then Cad = Cad & SpU
    If Caracteres(6).Value = 1 Then Cad = Cad & ExtraCHR.Text
    MsgBox "El Proceso esta por Comenzar, esto podria tardar mucho tiempo para frenarlo presione Ctrl+Shift+Esc y termine el proceso, el diccionario quedara incompleto (este se guarda en c:\Dic7913.txt)", vbInformation, "Atencion - Por Comenzar"
    Call Inicio ' llamo al inicio de proceso
End Sub

Private Sub MinMaxL_KeyPress(Index As Integer, KeyAscii As Integer)
    If Not IsNumeric(Chr(KeyAscii)) Then KeyAscii = 0 'Verifica que solo se ingresen numeros en el desde hasta.
End Sub

Private Function CharSplit7913(expression As String) As String()
    Dim lExp     As Long
    Dim ExpB()   As Byte
    Dim AuxArr() As String
    ExpB = expression
    lExp = UBound(ExpB)
    ReDim AuxArr(lExp)
    For X = 0 To lExp Step 2
        AuxArr(X / 2) = ChrW(ExpB(X))
    Next
    ReDim Preserve AuxArr(Int(lExp / 2))
    CharSplit7913 = AuxArr
End Function

Dim ABC (25)
Cadena = LCase(InputBox("Inserte cadena a analizar","RETO"))
For X = 1 To Len (Cadena)
    Letra = mid(Cadena,x,1)
    NumLetra = asc(Letra)-97
    ABC(NumLetra) = ABC(NumLetra) & Letra
Next

For x = 24 To 0 Step -1
    For y = 0 to x
        If Len(ABC(y)) > Len(ABC(y + 1)) Then
            temp = ABC(y+1)
            ABC(y + 1) = ABC(y)
            ABC(y) = temp
        End If
    Next
Next 

Do 
    Flag = True
    For x = 0 to 24
        If Len(ABC(x))=Len(abc(x+1)) Then
            If Asc(Right(ABC(x),1)) < Asc(Right(ABC(x + 1),1)) Then
                temp = ABC(x)
                ABC(x) = ABC(x + 1)
                ABC(x + 1) = temp
                Flag = Flase
            End If
        End If
    Next
Loop Until Flag

For X = 0 to 25
    Out = Out & RIGHT(ABC(x),1)
Next

Inputbox "Resultado", "RETO", strreverse(Out)