18	SERVICIOS
182	Seguros
1820	Inventarios
18202	Inventarios
182020	Mercaderías
1820201	Mercaderías
18202011	Mercaderías

Saludos a todos: Que cuando ingrese números en 2 dígitos (18 SERVICIOS), ambos que cambien el color del texto.

Gracias.

Sube un archivo Excel con un ejemplo detallado de lo que tienes, de lo que pretendes hacer y en que momento.

Mediante un macro, cambie de color de acuerdo a la cantidad de  dígitos en números, adjunto archivo en Excel.

Gracias.

Cambio de color de texto..xlsx

Hola JUANDEDIOS, la verdad es que no detallas lo que solicita el Maestro Antoni, pero te dejo una opción mediante formulario en el cual debes introducir un número, después un texto y por ultimo pulsar en el botón guardar. Prueba y comenta.

Cambio de color de texto..xlsm

Excelente.

Gracias, el ingreso que debo hacer en en excel, que no tenga formulario, los datos ingresados corresponden a un listado del Plan Contable. 

Saludos.

Cambio de color de texto..xlsx

Prueba el adjunto y comenta

Cambio de color de texto.(Prueba2).xlsm

Gracias, le agradezco mucho por la ayuda.

 

Si funciona le solicito, favor una revisión con respecto de la posición de los números de acuerdo a la cantidad de dígitos, lo realicé la codificación, pero alguito falta para que sea correcto.

Saludos.

Cambio de color de texto. - copia.xlsm

Prueba y comenta. Y no olvides agradecer a quien te ayuda o intenta ayudar mediante el corazoncito que hay en la parte inferior derecha de cada mensaje.

Cambio de color de texto. Prueba (3).xlsm

Excelente, funciona. Ahora a trabajar.

Gracias le agradezco mucho.

Saludos.

Quiero perfeccionar el funcionamiento de la macro, algo creo que me falta.

 

Gracias.

Cambio de color de texto. - copia.xlsm

@JUANDEDIOS, creo que tu macro esta bien, solo que en tu hoja tienes varias filas con datos hacia abajo (filas 150 y tanto) y eso entorpece la macro.

con esta, que es igual, funciona siempre sobre la fila que estes cambiando

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim color As Long
    Dim ufh1 As Long

    If Not Application.Intersect(Target, Range("A:B")) Is Nothing Then
           ' ufh1 = Hoja1.Range("A" & Rows.Count).End(xlUp).Row
          
        Select Case Len(Cells(Target.Row, 1))
        
            Case Is = 2
            Target.IndentLevel = 0
            color = RGB(254, 0, 0)
            Case Is = 3
            Target.IndentLevel = 1
            color = RGB(128, 0, 128)
            Case Is = 4
            Target.IndentLevel = 2
            color = RGB(0, 0, 0)
            Case Is = 5
            Target.IndentLevel = 3
            color = RGB(0, 255, 255)
            Case Is = 6
            Target.IndentLevel = 4
            color = RGB(0, 0, 255)
            Case Is = 7
            Target.IndentLevel = 5
            color = RGB(255, 0, 255)
            Case Is = 8
            Target.IndentLevel = 6
            color = RGB(0, 180, 0)
        
        End Select
        
        With Hoja1
            .Range(Cells(Target.Row, 1), .Cells(Target.Row, 2)).Font.color = color
        End With
 
    End If
End Sub

 

Gracias, bueno tengo que ingresar mas de 8,000 filas, como resolverlo?

Saludos.