VBA: 6174 La Constante de Kaprekar

Existen muchas curiosidades matemáticas y hoy veremos uno de ellos: La constante de Kaprekar, el 6174.

Básicamente este matemático indio (Dattatreya Ramachandra Kaprekar) demostró que con algunas condiciones y un orden concreto en unas operaciones, a partir de un número de cuatro dígitos, siempre se llega al número 6174.

Puedes leer algo más en nuestra amiga Wikipedia (aquí).

En resumen la operación a realizar consiste en seguir los siguientes pasos:
1- Escoger cualquier número de cuatro dígitos (OOJO!!, existen algunas limitaciones).
2- Ordenar los cuatro dígitos en orden ascendente, para obtener el minuendo de una resta.
3- Ordenar los mismos cuatro dígitos en orden descendente, para obtener el sustraendo de la misma resta.
4- Calcular la diferencia, restando el sustraendo del minuendo.
Si el resto no es igual a 6174, repetir los cuatro pasos anteriores, añadiendo ceros a la derecha al minuendo y a la izquierda al sustraendo, siempre que sea necesario para completar los cuatro dígitos.

Por ejemplo, si elegimos el 2784, manualmente el proceso sería:
8742 2478 =6264 (8742-2478)
6642 2466 =4176 (6642-2466)
7641 1467 =6174 (7641 - 1467)

En nuestro caso aplicaremos el ya conocido algoritmo de burbuja para ordenar los dígitos de cada número (ver aquí)...
Y para el proceso iterativo aplicaremos el bucle DO...LOOP UNTIL

Insertaremos el siguiente procedimiento en un módulo estándar:

Sub Kaprekar()
Dim numero As Long
inicio:
numero = Application.InputBox("Introduce un númerode cuatro dígitos", "Kaprecar en Excel")
'controlamos se cumplen las condiciones básicas:
'número de cuatro dígitos
If Len(numero) <> 4 Then
    GoTo inicio
ElseIf Not IsNumeric(numero) Then
    GoTo inicio
End If

'limpiamos el rango
Range("A1").CurrentRegion.ClearContents

'1. Escoger cualquier número de cuatro dígitos.
'2. Ordenar los cuatro dígitos en orden ascendente, para obtener el minuendo de una resta.
'3. Ordenar los mismos cuatro dígitos en orden descendente, para obtener el sustraendo de la misma resta.
'4. Calcular el resto, restando el sustraendo del minuendo.
'5. Si el resto no es igual a 6174, repetir los cuatro pasos anteriores, añadiendo ceros a la derecha al minuendo y a la izquierda al sustraendo, siempre que sea necesario para completar los cuatro dígitos.

fila = 0
diferencia = numero

'para controlar la inserción de valores numéricos NO válidos
On Error GoTo control
Do
    'obtenemos el valor ordenado en descendente
    ordDESC = OrdNumero(diferencia, "DESC")
    With Range("A1").Offset(fila, 0)
        .Value = ordDESC
        .NumberFormat = "0000"
    End With
    
    'obtenemos el valor ordenado en ascendente
    ordASC = OrdNumero(diferencia, "ASC")
    With Range("A1").Offset(fila, 1)
        .Value = ordASC
        .NumberFormat = "0000"
    End With
    
    'y su diferncia para hacerlo recursivo en pasos siguientes
    diferencia = ordDESC - ordASC
    With Range("A1").Offset(fila, 2)
        .Value = diferencia
        .Font.Bold = True
        .NumberFormat = "0000"
    End With
    
    fila = fila + 1
Loop Until diferencia = 6174 'contante de Kaprekar

Exit Sub

control:
If Err.Number > 0 Then MsgBox "Número no válido"
Exit Sub
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function OrdNumero(ByVal numero As Long, tipo As String) As String
Dim i As Long, j As Long

'definimos una Array de elementos a ordenar
Dim v(1 To 4) As Integer
For i = 1 To 4
    v(i) = Mid(numero, i, 1)
Next i

'procesamos el algoritmo de burbuja
For i = 1 To UBound(v)
    For j = i To UBound(v)
        If UCase(tipo) = "ASC" Then         'para ordenar en Ascendente
            If Val(v(j)) < Val(v(i)) Then
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        ElseIf UCase(tipo) = "DESC" Then    'y en descendente
            If Val(v(j)) > Val(v(i)) Then
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        Else    'para fallos u otros casos en Ascendente
            If Val(v(j)) < Val(v(i)) Then
                t = v(i)
                v(i) = v(j)
                v(j) = t
            End If
        End If
    Next j
Next i

'recomponemos el número ordenado
For x = 1 To 4
    rdo = rdo & v(x)
Next x

'y lo devolvemos a la función
OrdNumero = Val(rdo)

End Function

Listos, puedes probar con cualquier número de cuatro dígitos, a excepción de los números de cuatro dígitos iguales y algunos números de cuatro dígitos con tres números repetidos (si no se añadieran ceros a la derecha al minuendo y a la izquierda al sustraendo para completar los cuatro dígitos)...