Resaltar palabras especificas en una celda.

[Liizziie]

Buen día foro, espero todos se encuentren de maravilla. 

La cuestión es la siguiente, estoy tratando de resaltar algunas palabras en un archivo en excel que tengo para usar de referencia para los usuarios. 

Como forma de entrenamiento tenemos en formato excel la norma ISO y para entrenamiento estoy tratando de darle un color diferente a todos los "debe" que encuentre en el texto, pero no he logrado identificar como puedo hacerlo, creen que sea posible? 

Por ejemplo si en una celda tengo lo siguiente: "La organización debe planificar, implementar y controlar los procesos (véase 4.4) necesarios para cumplir los requisitos para la provisión de productos y servicios, y para implementar las acciones determinadas en el capítulo 6, mediante:" me gustaria que la palabra "debe" este en color rojo para que sea facil de encontrar al abrir el archivo de excel .

Muchas Gracias por su soporte.

[Israel Cassales]

Este código debería servirte, sólo modifica al rango como lo necesites.

Sub Buscar_Debe()
    Dim Rng As Range, celda As Range, posicion As Integer
    Dim palabra As String
   Set Rng = Range("A1:B11")
    On Error Resume Next
    palabra = "Debe"
    For Each celda In Rng
         posicion = InStr(1, celda, palabra, vbTextCompare)
            Do Until posicion = 0
                 With celda.Characters(posicion, Len(palabra)).Font
                    .Color = vbRed
                    .Bold = True
                 End With
                 posicion = InStr(posicion + 1, celda, palabra, vbTextCompare)
            Loop
    Next celda
    End Sub

Saludines

[Liizziie]

On 2/13/2023 at 4:15 PM, Israel Cassales said:

Este código debería servirte, sólo modifica al rango como lo necesites.

Sub Buscar_Debe()
    Dim Rng As Range, celda As Range, posicion As Integer
    Dim palabra As String
   Set Rng = Range("A1:B11")
    On Error Resume Next
    palabra = "Debe"
    For Each celda In Rng
         posicion = InStr(1, celda, palabra, vbTextCompare)
            Do Until posicion = 0
                 With celda.Characters(posicion, Len(palabra)).Font
                    .Color = vbRed
                    .Bold = True
                 End With
                 posicion = InStr(posicion + 1, celda, palabra, vbTextCompare)
            Loop
    Next celda
    End Sub

Saludines

Hola!!

Muchas Gracias por el código, sin embargo se me cicla el archivo... no me permite avanzar no estoy segura si es por las palabras que cambie a ingles, ya que mi excel esta en version ingles o que sea por que son aprox 1165 celdas donde debe buscar la palabra "debe".

Otra duda.. si quisiera buscar y resaltar mas de una palabra en diferentes colores, solo deberia repetir el codigo la cantidad de veces necesarias, correcto? 

Gracias! 

[Israel Cassales]

No necesariamente repetir el código N veces, en ese caso podrías agregar un Inputbox que te permita interactuar con la sentencia y estar modificando la palabra a cambiar igual que el color.

En este momento ando un poco atareado (y me disculpo por ello) para ayudarte pero estás en el sitio correcto para recibir más opciones.

Saludines.

[Liizziie]

On 2/15/2023 at 8:58 AM, Israel Cassales said:

No necesariamente repetir el código N veces, en ese caso podrías agregar un Inputbox que te permita interactuar con la sentencia y estar modificando la palabra a cambiar igual que el color.

En este momento ando un poco atareado (y me disculpo por ello) para ayudarte pero estás en el sitio correcto para recibir más opciones.

Saludines.

Muchas Gracias por el aporte!!! 

Estuve jugando con el codigo que me hiciste favor de compartir y logre lo que necesitaba; probablemente exista una manera mas sencilla, pero se logro el objetivo. 

Muchas Gracias Nuevamente. 

Dejo el código por si alguien lo llegara a necesitar.

Saludos!!

Sub debe()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Debe"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbRed
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Mantener()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Mantener"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbCyan
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Información()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Información Documentada"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = RGB(255, 153, 0)
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Revision()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "la revisión por la dirección"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = RGB(0, 176, 80)
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Retener()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "retener"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbMagenta
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Mantenidos()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Mantenidos"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbCyan
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub Mantenerse()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Mantenerse"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbCyan
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub conservar()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "conservar"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbMagenta
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub registros()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "registros"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbMagenta
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub mantiene()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Mantiene"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = vbCyan
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub documentada()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Documentada"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = RGB(255, 153, 0)
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub
Sub documentados()
Dim Rng As Range, celd As Range, position As Integer
    Dim word As String
   Set Rng = Range("A1:B1165")
    On Error Resume Next
    word = "Documentado"
    For Each cell In Rng
         position = InStr(1, cell, word, vbTextCompare)
            Do Until position = 0
                 With cell.Characters(position, Len(word)).Font
                    .Color = RGB(255, 153, 0)
                    .Bold = True
                 End With
                 position = InStr(position + 1, cell, word, vbTextCompare)
            Loop
    Next cell
End Sub