Encontrar Palabra o frase dentro de una celda que contiene una frase EXCEL
Tengo dos tablas en diferentes hojas de un promedio de 50000 registros. Necesito cruzarlas y poner en una columna la Palabra o Frase encontrada. Veamos con una imagen:
Como pueden ver, Necesito encontrar por ejemplo: BAGUA PUEBLO o BAGUA en la tabla de Denominación del activo, si lo encuentra entonces debe ponerle el nombre BAGUA PUEBLO en una columna a la derecha.
Puede existir mas de 1 registro que contenga la palabra BAGUA PUEBLO O BAGUA, entonces tendrá que poner en el RESULTADO BAGUA PUEBLO a todas las coincidencias.
1 Respuesta
Hola Dante,
Las tablas están en diferentes hojas pero si es más fácil para LA respuesta no hay problema si lo consideras en la misma hoja. Te adjunto la imagen completa.
H o l a:
Te anexo la macro para que funcione en 2 hojas.
Cambia "Hoja3" por la hoja donde tienes las denominaciones.
Cambia "Hoja4" por la hoja donde tienes los nombres locales
Cambia "E" por la columna en donde tienes los nombres locales.
Sub EncontrarPalabra()
'Por.Dante Amor
Set h1 = Sheets("Hoja3")
Set h2 = Sheets("Hoja4")
co2 = "E"
'
u = h1.Range(co2 & Rows.Count).End(xlUp).Row
If u < 4 Then u = 4
h1.Range("C3:C" & u).ClearContents
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
Set r = h1.Columns("B")
Set b = r.Find(h2.Cells(i, co2), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
'
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
dato = Split(h2.Cells(i, co2), " ")
For j = LBound(dato) To UBound(dato)
Set r = h1.Columns("B")
Set b = r.Find(dato(j), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
Next
MsgBox "Fin"
End Sub‘
F E L I Z A Ñ O T E D E S E A D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
Dante,
Hay un problema, el detalle es que cuando busca "MARIA" dentro de la columna Denominacion, captura MARIANO como si fuese MARIA.
Podrías hacerlo para que busque palabras o frases exactas.Es decir Si el nombre local es "SANTA MARIA NIEVA" entonces que busque en primer lugar la frase completa y si no se encuentra buscarlo por cada palabra pero que coincida la Palabra exacta. GRACIAS
Ya lo hace, la macro busca primero la frase completa y después busca palabra por palabra.
La macro no está buscando palabras exactas, está buscando coincidencias y "maria" coincide con "mariano"
Después de buscar la palabra voy a buscar que la palabra sea exacta.
Te anexo la macro actualizada.
Sub EncontrarPalabra()
'Por.Dante Amor
Set h1 = Sheets("Hoja3")
Set h2 = Sheets("Hoja4")
co2 = "E"
'
u = h2.Range(co2 & Rows.Count).End(xlUp).Row
If u < 4 Then u = 4
h1.Range("C3:C" & u).ClearContents
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
Set r = h1.Columns("B")
Set b = r.Find(h2.Cells(i, co2), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
nombre = Split(h2.Cells(i, co2), " ")
If UBound(nombre) = 0 Then
frase = Split(h1.Cells(b.Row, "B"), " ")
For j = LBound(frase) To UBound(frase)
If UCase(frase(j)) = UCase(nombre(0)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
Else
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
'
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
dato = Split(h2.Cells(i, co2), " ")
For j = LBound(dato) To UBound(dato)
Set r = h1.Columns("B")
Set b = r.Find(dato(j), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
frase = Split(h1.Cells(b.Row, "B"), " ")
For k = LBound(frase) To UBound(frase)
If UCase(frase(k)) = UCase(dato(j)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
Next
MsgBox "Fin"
End SubR ecuerda valorar la respuesta. G r a c i a s
Dante,
Me sale el siguiente error:
Necesito que me digas qué datos tienes, el problema es en los datos.
Ejecuta la siguiente macro y te va a poner en la hoja2 en la celda B1 la denominación
Revisa esa denominación en la hoja1 y dime qué es lo que tienes, tienes una fórmula o datos raros, envíame una pantalla para ver qué tienes en esa denominación.
Sub EncontrarPalabra()
'Por.Dante Amor
Set h1 = Sheets("Hoja3")
Set h2 = Sheets("Hoja4")
co2 = "E"
'
u = h2.Range(co2 & Rows.Count).End(xlUp).Row
If u < 4 Then u = 4
h1.Range("C3:C" & u).ClearContents
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
Set r = h1.Columns("B")
Set b = r.Find(h2.Cells(i, co2), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
nombre = Split(h2.Cells(i, co2), " ")
If UBound(nombre) = 0 Then
frase = Split(h1.Cells(b.Row, "B"), " ")
For j = LBound(frase) To UBound(frase)
If UCase(frase(j)) = UCase(nombre(0)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
Else
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
'
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
dato = Split(h2.Cells(i, co2), " ")
For j = LBound(dato) To UBound(dato)
Set r = h1.Columns("B")
Set b = r.Find(dato(j), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
h2.[B1] = h1.Cells(b.Row, "B")
frase2 = Split(h1.Cells(b.Row, "B"), " ")
For k = LBound(frase2) To UBound(frase2)
If UCase(frase2(k)) = UCase(dato(j)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
Next
MsgBox "Fin"
End SubCorrige la denominación y ejecuta nuevamente la macro.
Si todo está bien, recuerda valorar la respuesta.
Creo que encontré el problema. En mi columna denominación tenia muchos espacios en blanca entre palabras y al final de la frase. aplique =ESPACIOS(CELDA) y se soluciono. Gracias Dante te pasaste.
Creo que también me sale porque ya no encuentra más resultados. No se exactamente mi campo denominación muestra solo texto. Te mando este mensaje porque me volvió a ocurrir justo ahora a pesar de haber solucionado los espacios.
En el campo denominación a veces puedo tener simbolos como: %$#/()=:.-,..etc.
La macro no se encarga de validar información, la revisión de información debería corresponder a otra macro.
Como no sé toda la clases de problemas que puedas tener en tu información, agregué la instrucción On error resume Next, a la macro, la macro no se va a detener por problemas en tu información. Pero no pondrá los resultados de coincidencia, es decir, te va a dejar en blanco lo que no encuentre, ya tendrás que revisar manualmente las celdas que se quedaron en blanco.
Sub EncontrarPalabra()
'Por.Dante Amor
On Error Resume Next
Set h1 = Sheets("Hoja3")
Set h2 = Sheets("Hoja4")
co2 = "E"
'
u = h2.Range(co2 & Rows.Count).End(xlUp).Row
If u < 4 Then u = 4
h1.Range("C3:C" & u).ClearContents
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
Set r = h1.Columns("B")
Set b = r.Find(h2.Cells(i, co2), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
nombre = Split(h2.Cells(i, co2), " ")
If UBound(nombre) = 0 Then
frase = Split(h1.Cells(b.Row, "B"), " ")
For j = LBound(frase) To UBound(frase)
If UCase(frase(j)) = UCase(nombre(0)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
Else
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
'
For i = 3 To h2.Range(co2 & Rows.Count).End(xlUp).Row
dato = Split(h2.Cells(i, co2), " ")
For j = LBound(dato) To UBound(dato)
Set r = h1.Columns("B")
Set b = r.Find(dato(j), lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
If h1.Cells(b.Row, "C") = "" Then
'h2.[B1] = h1.Cells(b.Row, "B")
frase2 = Split(h1.Cells(b.Row, "B"), " ")
For k = LBound(frase2) To UBound(frase2)
If UCase(frase2(k)) = UCase(dato(j)) Then
h1.Cells(b.Row, "C") = h2.Cells(i, co2)
End If
Next
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Next
Next
MsgBox "Fin"
End Subsal u dos
