Como buscar letras en una celda donde tiene mucho texto y que me la pinte.
Tengo el Siguiente código pero este me busca el valor exacto y me pinta toda la celda yo necesito que busque letras iguales que estén en el texto y me las pinte.
Sub Comparacion()
'
' Comparacion Macro
'
' Acceso directo: CTRL+d
Set h1 = Sheets("Hoja1")
For i = 2 To h1.Range("C" & Rows.Count).End(xlUp).Row
For Each h In Sheets
Select Case h.Name
Case Is <> h1.Name
Set b = h.Cells.Find(h1.Cells(i, "C"), lookat:=xlWhole)
If Not b Is Nothing Then
b.Interior.ColorIndex = 4
End If
End Select
Next
Next
MsgBox "Fin"
End Sub
Lo que necesito es esto tengo en la hoja 1 esta columna
Y en la hoja 2 algo así
Necesito que la macro me pinte las letras que están el la hoja 1 en cualquier texto de la hoja 2 que tenga las mismas letras así debería quedar:
1 respuesta
H o l a : Te anexo la macro
Sub Comparacion()
'Act.Por.Dante Amor
' Acceso directo: CTRL+d
Set h1 = Sheets("Hoja1")
wcol = 3
For i = 2 To h1.Range("C" & Rows.Count).End(xlUp).Row
texto = h1.Cells(i, "C")
For Each h In Sheets
If h.Name <> h1.Name Then
Set r = h.Cells
Set b = r.Find(texto, LookAt:=xlPart)
If Not b Is Nothing Then
celda = b.Address
Do
'detalle
ini = InStr(1, b.Value, texto)
largo = Len(texto)
b.Characters(Start:=ini, Length:=largo).Font.ColorIndex = wcol
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
End If
Next
wcol = wcol + 1
Next
MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Oye si hace lo que quiero pero no me esta buscando todas las palabras de la hoja1("A") en la hoja 2
Mira todas las que están en amarillo tienen que ir resaltados y eso que faltan y no las esta pintando.
Según tu macro las palabras están en la columna "C"
Si las palabras están en la columna "A", entonces modifica la macro.
El texto "AU3" no lo veo en la lista de palabras que pusiste.
Revisa que se encuentre en la lista de palabras.
Revisa que esté bien escrito, que no tenga espacios en blanco ni antes ni después de la palabra.
Si yo ya cambie esa parte de "C" por "A"
Si esta en la lista solo que en la imagen que coloque no están todas las palabras porque esta lista es mucho mas larga y ademas de eso al ejecutar la macro se me bloquea en pc y no es porque sean muchos datos porque la ejecute con menos datos y se bloquea.
Y Pues ya mire esa parte y esta todo bien porque cuando busco las palabras por medio de ctr+b si las encuentra. Y no tienes espacios ni al principio ni al final.
Si quieres te la envió por correo y me ayudas.Gracias
Mira el error que sale
Ayuda profa.
Mira el error que aparece
Sí, envíame tu archivo para revisar tus datos.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “MARIA GUERLY GARCIA SOACHA” y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado.
S a l u d o s . D a n t e A m o r
Oye ya te envié el archivo a tu correo.
Macro actualizada para poner un color
Sub PoneColor()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.StatusBar = False
Set h1 = Sheets("Hoja1")
wcol = 3
u = h1.Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To u
texto = h1.Cells(i, "A")
Application.StatusBar = "Buscando palabra: " & texto & " Palabra " & i & " de: " & u
For Each h In Sheets
If h.Name <> h1.Name Then
Set r = h.Cells
Set b = r.Find(texto, LookAt:=xlPart)
If Not b Is Nothing Then
celda = b.Address
Do
ini = InStr(1, b.Value, texto)
largo = Len(texto)
mira = b.Address
b.Characters(Start:=ini, Length:=largo).Font.ColorIndex = wcol
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
End If
Next
Next
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Fin"
End Sub
