VBA Excel: Pintar celdas con números capicúa

29.08.16

Buenas tardes, Sasha

Aquí va la rutina que hace lo que solicitas.

Voy a asumir que los números que tienen cero a la izquierda, deben ser considerados sin ellos.

Esto es: 01221 es un número capicúa. Si no fuese así, avisame y una leve corrección lo ajustaría.

Accede al Editor de VBA (Atajo: Alt + F11), inserta un módulo - si no tuvieras uno ya- y pega el siguiente código:

Sub ColorCap()
'by FeJoAl
'SASHA, Cambia el contenido de estas variables para adaptarlo a tu archivo:  
CeldaIni = "A1"
ElColor = 22
For Linea = 0 To Range(CeldaIni).CurrentRegion.Rows.Count
    ElNumero = Trim(Range(CeldaIni).Offset(Linea, 0).Value)
    LargoNum = Len(ElNumero)
    cont = 0
    Capic = True
        ExtrDer = Right(ElNumero, 1)
        ExtrIzq = Left(ElNumero, 1)
        If ExtrDer <> ExtrIzq Or Len(ElNumero) < 2 Then
            Capic = False
        Else
            For LimIzq = 1 To Int(LargoNum / 2)
                LimDer = LargoNum - cont
                CifraIzq = Mid(ElNumero, LimIzq, 1)
                CifraDer = Mid(ElNumero, LimDer, 1)
                If CifraDer <> CifraIzq Then
                    Capic = False
                    Exit For
                End If
                cont = cont + 1
            Next
        End If
    If Capic Then
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = ElColor
        Cuenta = Cuenta + 1
    Else
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = 0
    End If
Next
ElMensaje = IIf(Cuenta = 0, "NO SE ENCONTRÓ NUMERO CAPICUA ALGUNO", "Fueron detectados " & Cuenta & " número" & IIf(Cuenta > 1, "s", "") & " capicúa.")
ElTitulo = "RANGO TERMINADO!"
MsgBox ElMensaje, vbInformation, ElTitulo
End Sub

Si el listado no empieza en A1, cambia esa referencia dentro de la variable CeldaIni al principio del código. Otro tanto si el color a utilizar no fuese el que yo elegí.

Esta macro actúa en la hoja activa. Por ello, tal vez quieras asignarle un atajo a esta macro ("Volver") de forma tal que puedas utilizarla más fácilmente en cada hoja.

 Para lo del atajo, haz:

 "Vista" | "Macros" (o con atajo: Alt + F8)

Selecciona allí (un sólo click sobre) la nueva rutina ingresada y presiona el botón "Opciones". En la pantalla siguiente ingresa una letra a la que quieres asociar la macro. Por supuesto evita aquellas que ya están siendo utilizadas por MS Excel como atajo (v.g. Ctrl + C, Ctrl + X, etc)

 Luego de aceptar, cuando presiones Ctrl más la letra indicada, la macro se ejecutará instantáneamente. Si fuese una letra que ya usa MS Excel, tendrás que presionar Ctrl + [Shift o tecla para Mayúsculas] + [Letra asignada]

.

.

Ah! Olvidé mencionar que la rutina no tiene límite de dígitos. Es decir que podría evaluar números superiores a 99999 y, eventualmente palíndromos.

Saludos

Fernando

.

ANtes que nada, excelente el trabajo. EL tema es que sí, son boletos de bus de un coleccionista y requiere evaluar los ceros a la izquierda pues el 01210 es capicúa y no así el 1210. ¿Cuál sería la corrección?

No sé si se publicó la otra respuesta:
Primero que nada, excelente tu explicación. Ayuda muchísimo. Ahora necesitaría esa variación porque como son viejos boletos de bus, es capicúa el 01210 pero no el 1210.

30.08.16

Hola, Sasha

En realidad, este sitio hace rato que tarda casi una hora en actualizar los post.

Vi tu pregunta en un mail que se dispara a mi cuenta de correo.

Allí noté, como me temía, que los ceros a la izquierda sí eran relevantes.

Si lo hubiera notado antes la rutina hubiera sido más simple. Pero me gustó el desafío.

Hice una simple modificación y esta es la rutina que lo hace:

Sub ColorCap()
'by FeJoAl
'SASHA, Cambia el contenido de estas variables para adaptarlo a tu archivo:
CeldaIni = "A1"
ElColor = 22
For Linea = 0 To Range(CeldaIni).CurrentRegion.Rows.Count
    ElNumero = Range(CeldaIni).Offset(Linea, 0).Value
    LargoNum = Len(ElNumero)
    cont = 0
    Capic = True
        ExtrDer = Right(ElNumero, 1)
        ExtrIzq = Left(ElNumero, 1)
        If ExtrDer <> ExtrIzq Or Len(ElNumero) < 2 Then
            Capic = False
        Else
            For PosIzq = 1 To Int(LargoNum / 2)
                PosDer = LargoNum - cont
                CifraIzq = Mid(ElNumero, PosIzq, 1)
                CifraDer = Mid(ElNumero, PosDer, 1)
                If CifraDer <> CifraIzq Then
                    Capic = False
                    Exit For
                End If
                cont = cont + 1
            Next
        End If
    If Capic Then
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = ElColor
        Cuenta = Cuenta + 1
    Else
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = 0
    End If
Next
ElMensaje = IIf(Cuenta = 0, "NO SE ENCONTRÓ NUMERO CAPICUA ALGUNO", "Fueron detectados " & Cuenta & " número" & IIf(Cuenta > 1, "s", "") & " capicúa.")
ElTitulo = "RANGO TERMINADO!"
MsgBox ElMensaje, vbInformation, ElTitulo
End Sub

Simplemente, quité la instrucción que eliminaba los ceros.

Probalo y decime si te funciona bien ahora.

Saludos

Fer

.

Cuando inicia la ejecución me dice "Se esperaba: Fin de la instrucción"

CeldaIni = "A1"

Y me marca en rojo las siguientes líneas:

If ExtrDer <> ExtrIzq Or Len(ElNumero) < 2 Then
If CifraDer <> CifraIzq Then
ElMensaje = IIf(Cuenta = 0, "NO SE ENCONTRÓ NUMERO CAPICUA ALGUNO", "Fueron detectados " & Cuenta & " número" & IIf(Cuenta > 1, "s", "") & " capicúa.")
ElTitulo = "RANGO TERMINADO!"

Además, las variables no están definidas y no sé de qué tipo son en cada caso. Yo las añadí pero asigné a la mayoría como tipo String salvo las que obviamente son númericas que las asigné como Long.

.

Buenas, Sasha

Es curioso, porque -desde luego- probé la rutina con una serie de valores y funcionó correctamente.

Te sugeriría que copies completo el segundo código enviado, porque aparentemente faltó pegar algo.

Por ejemplo, bastaría que no tenga al final "End Sub" para que te arrojara ese mensaje.

Actualmente es poco útil definir las variables pues VBA ya las interpreta.

En rutinas más complejas podría hacerse para que se agilice la ejecución pero no es este caso.

Aún así, en el hipotético caso de que definas las variables dejaría los números como String, porque si no eliminaría los ceros a la izquierda y no queremos que eso pase.

Por tanto, intenta de nuevo con el segundo procedimiento y comentame si anduvo. Debería...

Saludos

Fernando

.

EL error me lo da con la rutina tal cual la pasaste. Ahora, por las dudas, lo copié y pegué en un bloc de notas para que elimine cualquier etiqueta HTML pero lo mismo.
Uso, por las dudas, el Office 2016. No sé si influenciará en algo, pero aclaro.

.

Entonces es probable que haya un conflicto de compatibilidad con la versión de VBA para 64 bits.

Como noté que está en rojo donde aparecen variables, opté por declararlas a todas, tal vez sea eso. Pero al no tener tu versión de Office, no puedo comprobarlo.

Intenta con este código y decime si funciona:

Sub ColorCap()
'by FeJoAl
'SASHA, Cambia el contenido de estas variables para adaptarlo a tu archivo:
'Declaricón de variables:
Dim CeldaIni As String
Dim ElColor As Integer
Dim Linea As Integer
Dim ElNumero As String
Dim LargoNum As Integer
Dim cont As Integer
Dim Cuenta As Integer
Dim Capic As Boolean
Dim ExtrDer As String
Dim ExtrIzq As String
Dim PosIzq As String
Dim PosDer As String
Dim CifraIzq As String
Dim CifraDer As String
Dim ElMensaje As String
Dim ElTitulo As String
CeldaIni = "A1"
ElColor = 22
For Linea = 0 To Range(CeldaIni).CurrentRegion.Rows.Count
    ElNumero = Range(CeldaIni).Offset(Linea, 0).Value
    LargoNum = Len(ElNumero)
    cont = 0
    Capic = True
        ExtrDer = Right(ElNumero, 1)
        ExtrIzq = Left(ElNumero, 1)
        If ExtrDer <> ExtrIzq Or Len(ElNumero) < 2 Then
            Capic = False
        Else
            For PosIzq = 1 To Int(LargoNum / 2)
                PosDer = LargoNum - cont
                CifraIzq = Mid(ElNumero, PosIzq, 1)
                CifraDer = Mid(ElNumero, PosDer, 1)
                If CifraDer <> CifraIzq Then
                    Capic = False
                    Exit For
                End If
                cont = cont + 1
            Next
        End If
    If Capic Then
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = ElColor
        Cuenta = Cuenta + 1
    Else
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = 0
    End If
Next
ElMensaje = IIf(Cuenta = 0, "NO SE ENCONTRÓ NUMERO CAPICUA ALGUNO", "Fueron detectados " & Cuenta & " número" & IIf(Cuenta > 1, "s", "") & " capicúa.")
ElTitulo = "RANGO TERMINADO!"
MsgBox ElMensaje, vbInformation, ElTitulo
End Sub

Eventualmente, si se interrumpe, habrá que revisar la declaración de esas variables. Tené en cuenta -como te dije antes- que ElNumero debe ser String para que no pierda los ceros a la izquierda.

Saludos

Fer

.

Desafortunadamente el resultado fue exactamente el mismo, marcando en rojo exactamente las mismas líneas.

.

Hay algo realmente extraño, puesto que no hay procedimiento externo alguno.

Por otra parte, como podrás ver, la cantidad de variables es grande y sólo marca algunas.

No sé si ayudará, pero en la primera línea del modulo donde está esta macro y antes de ella, coloca lo siguiente:

Option Explicit

Lamento no poder dar una solución certera porque no tengo acceso a una versión de 64 bits y en la mía funciona perfectamente.

¿Has intentado con otras rutinas de VBA que contengan variables?

Saludos

Fernando

.

¡Gracias!
No ha funcionado con nada. Y probé en otro equipo y sucede lo mismo. No tengo equipos con Windows 32 bits así que no sé qué hacer. Igual gracias.

.

Es una pena, porque realmente funciona y se adapta a gran cantidad de casos.

Al no tener posibilidad de probarla en equipos con versiones como la tuya, me puse a investigar y no encontré nada que afecte directamente a las instrucciones que usé para programar esta rutina.

Lo más cercano fue esto:

http://stackoverflow.com/questions/5506912/how-should-i-make-my-vba-code-compatible-with-64-bit-windows 

Pero no echa demasiada luz sobre el problema.

Se me ocurrió entonces ofrecerte que me envíes el archivo a tratar y te lo devuelvo resuelto con la rutina que sí funciona en mi equipo.

Mi dirección de e-mail es:

Fejoal(eenn)hotmail.com

Para enviarlo, reemplaza "(eenn)" con @ en la dirección que te di. Es para evitar a los programas que recolectan direcciones de e-mail (ya no saben qué inventar...)

Finalmente, respecto a aquel código con declaración de variables ajusté un par para que opere correctamente. En caso de que alguna vez quieras probarlo en otra versión de MS Excel, utiliza esta versión:

Option Explicit
Sub ColorCap()
'by FeJoAl
'SASHA, Cambia el contenido de estas variables para adaptarlo a tu archivo:
'Declaricón de variables:
Dim CeldaIni As String
Dim ElColor As Integer
Dim Linea As Integer
Dim ElNumero As String
Dim LargoNum As Integer
Dim cont As Integer
Dim Cuenta As Integer
Dim Capic As Boolean
Dim ExtrDer As String
Dim ExtrIzq As String
Dim PosIzq As Integer
Dim PosDer As Integer
Dim CifraIzq As String
Dim CifraDer As String
Dim ElMensaje As String
Dim ElTitulo As String
CeldaIni = "A1"
ElColor = 22
For Linea = 0 To Range(CeldaIni).CurrentRegion.Rows.Count
    ElNumero = Range(CeldaIni).Offset(Linea, 0).Value
    LargoNum = Len(ElNumero)
    cont = 0
    Capic = True
        ExtrDer = Right(ElNumero, 1)
        ExtrIzq = Left(ElNumero, 1)
        If ExtrDer <> ExtrIzq Or Len(ElNumero) < 2 Then
            Capic = False
        Else
            For PosIzq = 1 To Int(LargoNum / 2)
                PosDer = LargoNum - cont
                CifraIzq = Mid(ElNumero, PosIzq, 1)
                CifraDer = Mid(ElNumero, PosDer, 1)
                If CifraDer <> CifraIzq Then
                    Capic = False
                    Exit For
                End If
                cont = cont + 1
            Next
        End If
    If Capic Then
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = ElColor
        Cuenta = Cuenta + 1
    Else
        Range(CeldaIni).Offset(Linea, 0).Interior.ColorIndex = 0
    End If
Next
ElMensaje = IIf(Cuenta = 0, "NO SE ENCONTRÓ NUMERO CAPICUA ALGUNO", "Fueron detectados " & Cuenta & " número" & IIf(Cuenta > 1, "s", "") & " capicúa.")
ElTitulo = "RANGO TERMINADO!"
MsgBox ElMensaje, vbInformation, ElTitulo
End Sub

Espero tu mail/comentario.

Saludos

Fer

.

H o l a: Te anexo la macro para todas las hojas. Cambia en la macro "A" por la columna en donde se encuentran los números.

Sub capicuo()
'Por.Dante Amor
    col = "A"               'columna con números
    For Each h In Sheets
        For i = 1 To h.Range(col & Rows.Count).End(xlUp).Row
            cad = ""
            num = Mid(h.Cells(i, col), 1)
            For k = Len(num) To 1 Step -1
                cad = cad & Mid(num, k, 1)
            Next
            If cad = num Then h.Cells(i, col).Interior.ColorIndex = 6
        Next
    Next
    MsgBox "Fin"
End Sub

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Al igual que con el otro código me da el mismo error:
Se esperaba: Fin de la instrucción

col = "A"