Buscar y copiar un dato en una celda
Saludos,
Tengo esta macro que me ayudo el Sr Dante Amor, ahora requiero que el mismo proceso me lo haga en la hoja donde me encuentre y la traslade a una hoja nueva. Que debo colocar en vez de Sheets (hoja1) y Sheets (Hoja2)
Sub BuscarVarios()
'Por.Dante Amor
Set h1 = Sheets("Hoja1") 'Hoja con datos
Set h2 = Sheets("Hoja2") 'Hoja con resultados
col = "A" 'columna con datos
valor = [B1] 'Valor a buscar
'
j = 1
h2.Cells.ClearContents
Set r = h1.Columns(col)
Set b = r.Find(valor, lookat:=xlPart)
If Not b Is Nothing Then
ncell = b.Address
Do
h1.Rows(b.Row).Copy h2.Rows(j)
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
h2.Select
MsgBox "Registros copiados a la hoja de resultados"
End Sub
1 Respuesta
Te anexo la macro actualizada
Sub BuscarVarios() 'Por.Dante Amor Set h1 = ActiveSheet 'Hoja con datos Set h2 = Sheets.Add(after:=Sheets(Sheets.Count)) 'Hoja con resultados col = "A" 'columna con datos valor = h1.[B1] 'Valor a buscar ' j = 1 Set r = h1.Columns(col) Set b = r.Find(valor, lookat:=xlPart) If Not b Is Nothing Then ncell = b.Address Do h1.Rows(b.Row).Copy h2.Rows(j) j = j + 1 Set b = r.FindNext(b) Loop While Not b Is Nothing And b.Address <> ncell End If h2.Select MsgBox "Registros copiados a la hoja de resultados" End Sub
Saludos.Dante Amor
