Anónimo
Buscar datos en rango de celdas y copiar fila en una hoja nueva
Tengo un pequeño problema.
Quiero buscar un dato dentro de un rango de celdas, y que si dentro de ese rango de celdas existe un 1 copié toda la fila una nueva hoja. El otro problema es que necesito que busque columna por columna de ese rango de celdas cada vez que se ejecute la macro, y que si en una de esas columnas aparece un 1 copié toda la fila.
[Hola
Prueba con esto y me comentas
Sub buscarx()
'//Todoexpertos
'[Por Adriel
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set l2 = Workbooks.Add
Set h2 = Sheets(1)
'
buscar = "peru" 'dato a buscar
Set rango = h1.Range("A1:D10") 'rango a buscar
'
For Each r In rango
Set b = r.Find(buscar, lookat:=xlWhole)
If Not b Is Nothing Then
f = b.Row
h1.Rows(f).Copy
h2.Range("A1").PasteSpecial xlValues
End If
Next
Application.CutCopyMode = False
End Sub
Te paso la macro actualizada
Sub buscarx()
'//Todoexpertos
'[Por Adriel
'
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
Set l2 = Workbooks.Add
Set h2 = l2.Sheets(1)
'
buscar = "peru" 'dato a buscar
Set rango = h1.Range("A1:D10") 'rango a buscar
'
For Each r In rango
Set b = r.Find(buscar, lookat:=xlWhole)
If Not b Is Nothing Then
f = b.Row
h1.Rows(f).Copy
h2.Range("A1").PasteSpecial xlValues
End If
Next
l2.SaveAs buscar
l2.Close
Application.CutCopyMode = False
End Sub
Hola. Desafortunadamente no me funciona.
Te adjunto foto de mi archivo. Me explicó un poco más. Del lado derecho tengo datos del cliente, del lado izquierdo tengo las fechas del mes(es el rango de celdas donde se va a buscar que haya un 1). Debajo de las fecha iré colocando número como indicadores, y cada vez que se encuentre un 1 deberá copiar toda la fila donde está ese 1 y pegarla en una hoja nueva del mismo archivo.
Prueba con esto
Sub buscarx()
'//Todoexpertos
'[Por Adriel
'
Set h1 = Sheets("Hoja1") 'hoja origen
Set h2 = Sheets("Hoja2") 'hoja destino
'
buscar = "1" 'dato a buscar
Set rango = h1.Range("G1:K30") 'rango a buscar
'
For Each r In rango
Set b = r.Find(buscar, lookat:=xlWhole)
If Not b Is Nothing Then
f = b.Row
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
'
h1.Rows(f).Copy
h2.Range("A" & u).PasteSpecial xlValues
End If
Next
Application.CutCopyMode = False
MsgBox "fin"
End Sub
Muchas gracias, funciona de maravilla. Solo una cosa más, los valores si se copian a la hoja nueva, solo que cada vez que se ejecuta la macro copia los valores que ya había copiado. Se podrá que solo copie los valores nuevo evitando copiar los que ya había copiado anteriormente??
Te paso la macro actualizada
Asumo que la columna M está vacía porque me servirá para verificar si la fila está copiada
Valorar la respuesta para finalizar saludos!
Sub buscarx()
'//Todoexpertos
'[Por Adriel
'
Set h1 = Sheets("Hoja1") 'hoja origen
Set h2 = Sheets("Hoja2") 'hoja destino
'
buscar = "1" 'dato a buscar
Set rango = h1.Range("G1:M30") 'rango a buscar
'
For Each r In rango
Set b = r.Find(buscar, lookat:=xlWhole)
If Not b Is Nothing Then
f = b.Row
If Cells(f, "M") <> "copiado" Then
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
'
h1.Rows(f).Copy
h2.Range("A" & u).PasteSpecial xlValues
h1.Range("M" & f) = "copiado"
End If
End If
Next
Application.CutCopyMode = False
MsgBox "fin"
End Sub