Problemas buscador de palabras en libro con palabras iguales en diferentes hojas.
tengo problemas con un código funciona bien, para buscar palabras o valores en un libro y dar como resultado el valor asociado, el problema es cuando la misma palabra de búsqueda se encuentra en 2 hojas diferentes.
por ejemplo al buscar "alimentos"
en hoja 2 se encuentran
alimentos minerales M203
alimentación proteínas M202
alimentos de origen vegetal M664
desnutrición y alimentos M522
y en hoja 3 se encuentran
alimentos de origen vegetal 827
alimentos de origen animal 558
alimentos 327
en vez de mostrar los 7 resultados se bloquea y sigue pegando los resultados sin cesar.
habrá forma de solucionarlo y que pueda también mostrar en que hoja se encontró el resultado.
el código es :
' *****MACRO***********
Sub buscarmono()
' Por Dam
' Busca monografías por una palabra y las copia a otra hoja
'
Application.ScreenUpdating
= False
Dim ufila,
ucolumna As Long
mono = InputBox(Prompt:="Palabra a buscar: ")
j = 2
una vez = 1
ultimo = 0
primera = 1
Worksheets("Buscador").Select
ufila =
ActiveCell.SpecialCells(xlLastCell).Row
Range(Cells(2, 5),
Cells(ufila, 6)).Clear
For hoja = 1 To Sheets.Count
nombrehoja =
Sheets(hoja).Name
Worksheets(nombrehoja).Select
ufila =
ActiveCell.SpecialCells(xlLastCell).Row
ucol =
ActiveCell.SpecialCells(xlLastCell).Column
Cells(1, 1).Select
For i = 1 To ufila
If una vez = 1 Then
Set RangoObj =
Cells.Find(What:=mono, _
After:=ActiveCell,
SearchOrder:=xlByRows)
una vez = 2
End If
Set RangoObj =
Cells.FindNext(After:=ActiveCell)
If RangoObj Is Nothing Then
'MsgBox ("Fin de la
Búsqueda de '" & mono & _
'"'. Se encontraron "
& j - 2)
ultimo = 1
Exit For
Else
If primera = 1 Then
primermono = RangoObj.Value
primera = 2
Else
If primermono = RangoObj Then
Exit For
End If
i = RangoObj.Row
nombre = Cells(i, 1).Value
clave = Cells(i, 2).Value
Worksheets("Buscador").Select
Cells(j, 6).Select
Cells(j, 5).Value = nombre
Cells(j, 6).Value = clave
j = j + 1
Worksheets(nombrehoja).Select
Cells(i, 6).Select
End If
Next i
Next hoja
Application.ScreenUpdating
= True
Worksheets("Buscador").Select
'If ultimo = 0 Then
MsgBox ("Fin
de la Búsqueda de '" & mono & _
"'" & vbNewLine &
vbNewLine & _
" Se encontraron " & j - 2
& " coincidencias")
'End If
End Sub
'***Macro*************
Gracias por cualquier ayuda.
1 Respuesta
Prueba a usar esta macro y me cuentas:
Sub ejemplo()
'por luismondelo
fila = 1
Application.DisplayAlerts = False
For Each hoja In ActiveWorkbook.Sheets
If hoja.Name = "xinformex" Then hoja.Delete
Next
Sheets.Add after:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Name = "xinformex"
dato = InputBox("qué dato buscamos????")
For x = 1 To Sheets.Count - 1
Sheets(x).Select
Set busca = ActiveSheet.UsedRange.Find(dato, LookIn:=xlValues, lookat:=xlWhole)
If Not busca Is Nothing Then
ubica = busca.Address
Do
Sheets("xinformex").Cells(fila, 1).Value = Sheets(x).Name & "---" & busca.Address(False, False)
fila = fila + 1
Set busca = ActiveSheet.UsedRange.FindNext(busca)
Loop While Not busca Is Nothing And busca.Address <> ubica
End If
ubica = ""
Set busca = Nothing
Next
MsgBox "los encuentros están anotados en la hoja xinformex"
Sheets("xinformex").Select
End Subno olvides finalizar la consulta
perdón pero no se donde esta el error al utilizar el macro solo crea 2 hojas en blanco al final de las demás una con el nombre xinformex, pero no pega ningún dato.
muchas gracias, no se por que antes no funcionaba pero ahora si, lo único es que ahora solo busca la palabra exacta. pero de ahi en fuera funciona muy bien gracias. me has sido de gran ayuda.
