Copiar datos de a cinco y pegarlos en otra hoja
Tengo la siguiente macro
Sub IMPORTAR()
'
' IMPORTAR Macro
'
Dim lr As Long, i As Long, a As Variant, r As Range
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("A" & lr + 1) 'establece la siguiente fila a la última fila con datos
a = Range("A1:A" & lr)
For i = 1 To UBound(a)
If a(i, 1) = "0" Then Set r = Union(r, Range("A" & i))
Next i
r.EntireRow.Delete
Application.ScreenUpdating = True
Range("b2").Select
'Sheets("Nombres").Select
Range("A1:A5").Select
Selection.Copy
Sheets("Etiquetas").Select
ActiveWindow.SmallScroll Down:=-51
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Nombres").Select
Range("A6:A10").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Nombres").Select
Range("A11:A15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Nombres").Select
Range("A16:A20").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Nombres").Select
Range("A21:A25").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Nombres").Select
ActiveWindow.SmallScroll Down:=12
Range("A26:A30").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
ActiveWindow.SmallScroll Down:=3
Sheets("Nombres").Select
Range("A31:A35").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Etiquetas").Select
Range("A7").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
end sub
Y quiero que esto lo haga hasta el final de los registros pueden ser 5 o 100000
Cuando lo lo pega en la hoja etiquetas lo hace con el modo transponer
[Hola Marcelo.
Veo que estás interesado en aprender a programar.
Te muestro un pequeño detalle. En las opciones del ciclo For puedes utilizar la opción Step, con esta opción, el contador cambia cada vez a través del bucle. Si no se especifica, el Step predeterminado es uno.
Otra recomendación es hacer referencia a las dos hojas, de esa manera podrás ejecutar la macro desde cualquier hoja.
Sub IMPORTAR_3()
Dim lr As Long, i As Long, j As Long, n As Long
Dim a As Variant
Dim r As Range
Dim sh1 As Worksheet, sh2 As Worksheet
'
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Nombres") 'hoja Origen
Set sh2 = Sheets("Etiquetas") 'hoja Destino
n = 5 'cantidad de datos a copiar
'
lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
Set r = sh1.Range("A" & lr + 1) 'establece la siguiente fila a la última fila con datos
a = sh1.Range("A1:A" & lr)
For i = 1 To UBound(a)
If a(i, 1) = "0" Then Set r = Union(r, sh1.Range("A" & i))
Next i
r.EntireRow.Delete
'
'En el For utilizas Step para aumentar el contador
For i = 1 To sh1.Range("A" & Rows.Count).End(xlUp).Row Step n
sh1.Range("A" & i).Resize(n, 1).Copy
'al inicio j vale 0, entonces despúes de sumar 1 el valor inicial será 1
j = j + 1
sh2.Range("A" & j).PasteSpecial xlPasteAll, , , True
Next
Application.ScreenUpdating = True
End SubRevisa que todas las etiquetas estén completas.
Avísame cualquier duda.
1 respuesta más de otro experto
Te dejo la macro ajustada:
Sub IMPORTAR()
'ajustada x Elsamatilde
'
Dim lr As Long, i As Long, a As Variant, r As Range
Dim x As Long, y As Long
Dim hoe
Application.ScreenUpdating = False
lr = Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("A" & lr + 1) 'establece la siguiente fila a la última fila con datos
a = Range("A1:A" & lr)
For i = 1 To UBound(a)
If a(i, 1) = "0" Then Set r = Union(r, Range("A" & i))
Next i
r.EntireRow.Delete
Application.ScreenUpdating = True
Set hoe = Sheets("Etiquetas")
i = 1 '1er fila para la hoja Etiqueta
y = Range("A" & Rows.Count).End(xlUp).Row 'fin de rango hoja Nombres
For x = 1 To y
Range("A" & x & ":A" & x + 4).Copy
hoe.Range("A" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'se incrementan las filas en las 2 hojas
x = x + 5: i = i + 1
Next x
MsgBox "Fin del proceso"
End Sub
¡Gracias! Le puedo decir que la amo!!! me estaba volñviendo loco pegando uno por uno
jejeje ;)
Cada vez que tienen que hacer alguna tarea repetitiva, deben pensar que hay un bucle, ciclo o estructura repetitiva que lo puede resolver.
Sdos!