Macro que me busque un valor y me regrese los múltiples valores de varios hojas dentro del mismo archivo
Tengo un archivo con varias hojas en total son 12, son reportes de pruebas a números de parte y quiero que con un macro me regrese todas las pruebas que se le han hecho a ese numero de parte
El numero de parte se sitúa en la columna E y los resultados en las celdas de DM a DT
Te anexo la macro. Debes crear una hoja llamada "Consulta", en esta hoja se reflejarán los resultados de la búsqueda.
Si quieres otro nombre, cambia en la macro "Consulta" por el nombre que desees.
Debes poner el número de parte en la celda B2 de la hoja consulta y ejecutar la macro.
El resultado te lo pondrá en la hoja Consulta en las columnas de la "D" a la "K"
Sub MultiplesValores()
'Por.Dante Amor
hoja = "Consulta"
Set h1 = Sheets(hoja)
h1.Range([D2], "K" & Rows.Count).ClearContents
'
j = 2
For Each h In Sheets
If h.Name <> hoja Then
Set r = h.Columns("E")
Set b = r.Find(h1.[B2], LookAt:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do: h.Range("DM" & b.Row & ":DT" & b.Row).Copy h1.Cells(j, "D")
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End If
Next
End SubSaludos.Dante Amor
No olvides valorar la respuesta.
Hola!!!
Sorry por no responder antes pero me marca un error
h1.Range([D2], "K" & Rows.Count).ClearContents
Y la verdad no se que pueda ser ya lo e revisado varias veces...
Muchas gracias por tu ayuda
¿Y qué mensaje de error te pone?
Me aparece el error 438
h1.Range([D2], "K" & Rows.Count).ClearContents me aparece en amarillo
Y qué más dice el error 438, puedes poner toda la descripción
También dime qué versión de excel tienes
Y si estás ejecutando o tienes otras macros
¿Creaste la hoja "Consulta"?
Prueba con esta macro
Sub MultiplesValores()
'Por.Dante Amor
hoja = "Consulta"
Set h1 = Sheets(hoja)
h1.Range(Range("D2"), "K" & Rows.Count).ClearContents
'
j = 2
For Each h In Sheets
If h.Name <> hoja Then
Set r = h.Columns("E")
Set b = r.Find(h1.Range("B2"), LookAt:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do: h.Range("DM" & b.Row & ":DT" & b.Row).Copy h1.Cells(j, "D")
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End If
Next
End Sub
Error 438
Objetivo doesn't su portal this property or method
Tengo la versión 2010 de excel
Sólo está macro es la que tengo en el archivo
Si creé la hoja de consulta...
me sigue marcando lo mismo en amarillo
h1.Range(Range("D2"), "K" & Rows.Count).ClearContents
También me aparece esto cuando le doy ejecutar
Can't excuses code in break mode
En la segunda macro borra esa línea y ejecuta nuevamente la macro.
¿Habías ejecutado anteriormente una macro en tu excel?
¿Tienes excel o alguna versión de openoffice?
Ya funcionó... pero no me arroja todos los resultados de todas las hojas sólo me da la mitad o menos de un total de 178 sólo me da de resultado 72
Si ya e ejecutado macros en este excel
Es la versión de office excel 2010
¿Todas las hojas están desprotegidas?
Quieres que busque el valor exacto o quieres que busque dentro de la celda un dato, por ejemplo en la celda E5 tienes esto: xd340005
Y en la hoja consulta pusiste esto: 340005, entonces la macro no lo encuentra.
Si quieres que lo encuentre, incluso que no importe las mayúsculas y minúsculas, entonces utiliza esta macro
Sub MultiplesValores()
'Por.Dante Amor
hoja = "Consulta"
Set h1 = Sheets(hoja)
'h1.Range(Range("D2"), "K" & Rows.Count).ClearContents
'
j = 2
For Each h In Sheets
If h.Name <> hoja Then
Set r = h.Columns("E")
Set b = r.Find(h1.Range("B2"), LookAt:=xlPart, MatchCase:=False)
If Not b Is Nothing Then
ncell = b.Address
Do
h.Range("DM" & b.Row & ":DT" & b.Row).Copy h1.Cells(j, "D")
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
End If
Next
End SubPrueba y me comentas
