Macro que busque un valor y copie la fila entera
Espero me puedan ayudar,
Necesito hacer una macro que me busque un valor en la hoja 1 y copie toda la fila a la hoja 2 sin sobreescribir el ultimo registro, y una vez copiada la fila, la elimine de la hoja 1
Necesito hacer una macro que me busque un valor en la hoja 1 y copie toda la fila a la hoja 2 sin sobreescribir el ultimo registro, y una vez copiada la fila, la elimine de la hoja 1
1 Respuesta
Respuesta de Luis Mondelo
3
Pues aquí tienes la macro que lo hace. La hoja a la que copio los datos la he llamado "COPIADOS". La macro se ejecuta en la pestaña donde realiza la búsqueda
Sub copiar_y_borrar()
quebusco = InputBox("que dato quieres buscar")
If quebusco = "" Then Exit Sub
Set busca = ActiveSheet.Range("a2:a" & Range("a10000").End(xlUp).Row).Find(quebusco, LookIn:=xlValues, lookat:=xlWhole)
If Not busca Is Nothing Then
busca.EntireRow.Copy
Sheets("copiados").Cells(Range("a10000").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValues
busca.EntireRow.Delete
Application.CutCopyMode = False
End If
End Sub
No olvides finalizar y puntar
Sub copiar_y_borrar()
quebusco = InputBox("que dato quieres buscar")
If quebusco = "" Then Exit Sub
Set busca = ActiveSheet.Range("a2:a" & Range("a10000").End(xlUp).Row).Find(quebusco, LookIn:=xlValues, lookat:=xlWhole)
If Not busca Is Nothing Then
busca.EntireRow.Copy
Sheets("copiados").Cells(Range("a10000").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValues
busca.EntireRow.Delete
Application.CutCopyMode = False
End If
End Sub
No olvides finalizar y puntar
Hola Experto!
Muchas gracias por tu pronta respuesta! Sin embargo quisiera preguntarte como puedo modificar la macro para que copie todas las filas que contengan el valor a buscar y en la hoja "Copiados" que me deje una fila vacía para identificar cada vez que se corrió la macros.
Si lo requieres te puedo enviar el archivo para mayor comprensión
Saludos y muchas gracias!
Muchas gracias por tu pronta respuesta! Sin embargo quisiera preguntarte como puedo modificar la macro para que copie todas las filas que contengan el valor a buscar y en la hoja "Copiados" que me deje una fila vacía para identificar cada vez que se corrió la macros.
Si lo requieres te puedo enviar el archivo para mayor comprensión
Saludos y muchas gracias!
Aquí tienes amigo. Te cuento mi plan: la base de datos está en la pestaña "hoja1" y los copiaremos en la pestaña "copiados". Los datos de la hoja1 empiezan desde A2 hacia abajo y esa es la columna por la que voy a buscar (lógicamente en la fila 1 de la hoja1 están los encabezados)
Sub copiar_y_borrar()
columna = Range("bz1").End(xlToLeft).Column
quebusco = InputBox("que dato quieres buscar")
If quebusco = "" Then Exit Sub
ActiveSheet.Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set busca = ActiveSheet.Range("a2:a" & Range("a10000").End(xlUp).Row).Find(quebusco, LookIn:=xlValues, lookat:=xlWhole)
If Not busca Is Nothing Then
ubica = busca.Address
Range(ubica).Select
valor = ActiveCell.Value
fila = ActiveCell.Row
contarsi = Application.WorksheetFunction.CountIf(Columns(1), valor)
Range(Cells(fila, 1), Cells(fila + contarsi - 1, columna)).Copy
Sheets("copiados").Select
Cells(Range("copiados!a10000").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValues
Selection.End(xlDown).Offset(1, 0).Value = "*****************"
Sheets("hoja1").Select
Range(Cells(fila, 1), Cells(fila + contarsi - 1, columna)).EntireRow.Delete
Application.CutCopyMode = False
End If
End Sub
Recuerda finalizar y puntuar
Sub copiar_y_borrar()
columna = Range("bz1").End(xlToLeft).Column
quebusco = InputBox("que dato quieres buscar")
If quebusco = "" Then Exit Sub
ActiveSheet.Range("a1").CurrentRegion.Sort key1:=Range("a1"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set busca = ActiveSheet.Range("a2:a" & Range("a10000").End(xlUp).Row).Find(quebusco, LookIn:=xlValues, lookat:=xlWhole)
If Not busca Is Nothing Then
ubica = busca.Address
Range(ubica).Select
valor = ActiveCell.Value
fila = ActiveCell.Row
contarsi = Application.WorksheetFunction.CountIf(Columns(1), valor)
Range(Cells(fila, 1), Cells(fila + contarsi - 1, columna)).Copy
Sheets("copiados").Select
Cells(Range("copiados!a10000").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValues
Selection.End(xlDown).Offset(1, 0).Value = "*****************"
Sheets("hoja1").Select
Range(Cells(fila, 1), Cells(fila + contarsi - 1, columna)).EntireRow.Delete
Application.CutCopyMode = False
End If
End Sub
Recuerda finalizar y puntuar
Te mando una corrección. Esta fila:
Selection.End(xlDown).Offset(1, 0).Value = "*****************"
Sustitúyela por esta:
Selection.Offset(1, 0).Value = "*****************"
Selection.End(xlDown).Offset(1, 0).Value = "*****************"
Sustitúyela por esta:
Selection.Offset(1, 0).Value = "*****************"
Sigue fallando, rectifico lo anterior:
Sutituye esta fila:
?Selection.End(xlDown).Offset(1, 0).Value = "*****************"
por esto:
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Value = "******************"
Sutituye esta fila:
?Selection.End(xlDown).Offset(1, 0).Value = "*****************"
por esto:
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Value = "******************"
Hola Experto, tengo malas noticias, ya realize los cambios que me sugeriste, y al correr la macro no sucede nada. en el editor de visual basic no me muestra error alguno. Cambie el nombre de las hojas en mi archivo a "hoja1" y "copiados" y sigue sin suceder nada.. Donde esta el error?
como siempre, gracias por todo tu apoyo.
saludos
La macro funciona perfectamente. Dime un mail y te lo mando.
Ya te lo he mandado.
Finaliza y puntúa
Que bárbaro!! Te volaste la barda!! muchísimas gracias la macro funciona a la perfección.!
yo te doy 7 estrellas!
Gracias por todo tu apoyo, no sabes de la que me has salvado!
SALUDOS! =)
Buenos días Luis! Saludos desde Costa Rica. Estaba navegando y creo que esta macro me va a servir mucho, soy más o menos principiante en VBA, me podrías confirmar por favor de esta macro cuáles son los espacios que debo reemplazar?Sub copiar_y_borrar()quebusco = InputBox("que dato quieres buscar")If quebusco = "" Then Exit SubSet busca = ActiveSheet.Range("a2:a" & Range("a10000").End(xlUp).Row).Find(quebusco, LookIn:=xlValues, lookat:=xlWhole)If Not busca Is Nothing Thenbusca.EntireRow.CopySheets("copiados").Cells(Range("a10000").End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlValuesbusca.EntireRow.DeleteApplication.CutCopyMode = FalseEnd IfEnd Sub - Julie Rojas
Hago referencia al primer código de la macro que enviaste como respuesta a esta pregunta jlre1. Gracias! - Julie Rojas