Copiar rango de celdas a partir de la celda activa a otra hoja del mismo libro
Tengo un rango de celdas que contienen formulas que llenan la información de las celdas.
Necesito copiar de este rango de celdas solo los valores de las celdas que se hayan poblado con información congruente o interesante. Para esto la columna A define si esta en blanco no debo de copiar la información contenida en las celdas A2:E2, caso contrario debo de copiar la información de este rango a otra hoja en el mismo archivo.
He creado un botón al que le he asignado la siguiente macro
Sub copiar_datos()
'Posicionarse en la celda A2
Range("A2").Select
'Mientras el valor de la celda activa sea diferente a ""
Do While ActiveCell.Value <> ""
Range(ActiveCell, ActiveCell.Offset(0, 4)).AutoFill Destination:=Range(ActiveCell.Offset(0, 10), ActiveCell.Offset(0, 14))
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Espero que al hacer clic sobre este botón toda la información valida de este rango sea copiada a otro rango. En este momento no estoy copiando la información a otra hoja, solo a un rango diferente de celdas en la misma hoja para probar el resultado, pero al momento de correr la macro Excel, me muestra el siguiente error
"Se ha producido el error 1004 en tiempo de ejecución error en el método AutoFill de la clase Range"
Qué estoy haciendo mal en esta macro y si se puede cual es la sintaxis correcta para copiar la información seleccionada a partir del valor de la celda activa en otra hoja mismo rango de celdas.
1 Respuesta
El método AutoFill no copia datos si no que auto rellena celdas, es como cuando arrastras una celda para repetir una fórmula o valores en otras celdas consecutivas, el error que te marca es porque los rangos A2:E2 y K2:O2 no son consecutivos.
Te dejo una macro que te puede servir
Sub ExtraerValores()
Dim Valores As Variant
Dim PrimerValor As Integer
Dim UltimoValor As Integer
Dim i As Integer
'El primer valor esta en la seguna fila(A2)
PrimerValor = 2
'Se busca cual es el ultimo valor
If Cells(PrimerValor, 1) = Empty Then
UltimoValor = PrimerValor
ElseIf Cells(PrimerValor + 1, 1) = Empty Then
UltimoValor = PrimerValor + 1
Else
UltimoValor = Cells(PrimerValor, 1).End(xlDown).Row
End If
'Se copian los valores
For i = PrimerValor To UltimoValor
'Se guardan los valores del rango A2:E2, A3:E3, etc
Valores = Range("A" & i).Resize(1, 5)
'Se escriben los valores en el nuevo rango K2:O2, K3:O3, etc
Range("K" & i).Resize(1, 5) = Valores
Next
End Sub
¡Gracias! por tu respuesta Alberto, me has dado una gran ayuda al explicarme el método AutoFill que no me había quedado del todo claro.
Te agradezco también la macro que me has enviado y te dejo la que finalmente deje funcionando en mi hoja de Excel en el afán de que le pueda servir a alguien más.
Sub copiar_datos()
'Mostramos la hoja de destino
Sheets("Vaciado").Visible = True
'Seleccionamos la hoja de datos u origen
Sheets("Transferencia").Select
'Posicionarse en la celda A2
Range("A2").Select
'Mientras el valor de la celda activa sea diferente a ""
Do While ActiveCell.Value <> ""
'Toma el valor de la celda activa
ubica = ActiveCell.Address(False, False)
'Selecciona a partir de la celda activa un rango de 5 filas en la misma linea
Range(ActiveCell, ActiveCell.Offset(0, 4)).Select
'Se marca el rango seleccionado para copiar CTRL+C
Selection.Copy
'Cambiamos a la Hoja de Destino
Sheets("Vaciado").Select
'Posicionarnos en la misma celda activa de la hoja de datos u origen
Range(ubica).Select
'Pegamos los valores seleccionados como valores CTRL + V Especial solo valores
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'Desactivamos la función de copiar y pegar
Application.CutCopyMode = False
'Regresamos a la hoja de datos
Sheets("Transferencia").Select
'Bajamos a la siguiente línea en el rango de datos
ActiveCell.Offset(1, 0).Select
'Retorno del ciclo While
Loop
'Ir a la hoja de destino
Sheets("Vaciado").Select
'Posicionarse en la celda A1
Range("A1").Select
End Sub
Saludos y hasta la próxima
Yo quiero esa misma macro, pero que me permita pegar los documentos en cualquier arcrivo - junior balbuena