Necesito copiar filas en diferentes libros
Tengo el siguiente código para copiar de un libro a otro una fila, pero necesito que este copie 200 filas mas y cada fila es un libro diferente. Con este código me esta copiando un solo registro, no se como duplicar el código sin necesidad de copiar la macro 200 veces. Gracias por la ayuda.
Sub Macro1()
Dim RutaArchvo As String
Dim NombreArchivo As String
Sheets("Hoja1").Range("A2:C2").Copy
Workbooks.Add
ActiveSheet.Cells(1, ("B")).PasteSpecial Paste:=xlPasteAll, Transpose:=True
RutaArchivo = "C:\Users\Usuario\Documents\Pruebas" & "\"
NombreArchivo = Range("B1").Value
ActiveWorkbook.SaveAs Filename:=RutaArchivo & NombreArchivo & ".xls" _
, FileFormat:=xlNormal
Application.DisplayAlerts = False
End Sub
2 Respuestas
Prueba lo siguiente. Recorre la columna A desde la fila 2 hasta la última fila con datos de la misma columna A. Por cada fila te genera un archivo.
Sub Macro1()
Dim RutaArchivo As String
Dim sh As Worksheet
Dim l2 As Workbook
Dim i As Long
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'
Set sh = Sheets("Hoja1")
RutaArchivo = "C:\Users\Usuario\Documents\Pruebas\"
'
For i = 2 To sh.Range("A" & Rows.Count).End(3).Row
sh.Range("A" & i & ":C" & i).Copy
Set l2 = Workbooks.Add
With l2.Sheets(1).Range("B1")
.PasteSpecial Paste:=xlPasteAll, Transpose:=True
l2.SaveAs RutaArchivo & .Value & ".xls", xlNormal
l2.Close False
End With
Next
End Sub
¡Gracias! Dante, funciono perfecto!
.
[Nota: Si te es posible cambiar la valoración.
Modifica esta línea:
Sheets("Hoja1"). Range("A2:C2"). Copy
Después de la C modifica el 2 y pon la última fila que quieras copiar. Creo que con eso bastaría, sino probaré el código.
Hola Jordi
Gracias por tu respuesta. Probé y me copia toda la información, no fila por fila en cada libro como lo necesito
Ahh, creo que ya se lo que quieres. Sin embargo, tendrás que ponerle un nombre diferente a cada libro. Copia exactamente esto y modifica primera fila y última fila para que encaje con las que quieres. A los nombres de los archivos les he añadido un _X siendo X el número de fila. Piensa que dos archivos en el mismo directorio no pueden tener el mismo nombre. Además fijate que te copia las filas traspuestas y en la columna B. Si hay alguna pequeña modificación que no sabes hacer me lo puedes comentar y te lo edito de nuevo.
Option Explicit
Public Sub Macro1()
Dim RutaArchivo As String, NombreArchivo As String
Dim i As Integer, primeraFila As Integer, ultimaFila As Integer
Dim wb As Workbook, sht1 As Worksheet, sht2 As Worksheet
RutaArchivo = "C:\Users\Usuario\Documents\Pruebas\"
primeraFila = 2
ultimaFila = 3
NombreArchivo = Range("B1").Value
Set sht1 = Application.ActiveWorkbook.Sheets("Sheet1")
Set wb = Workbooks.Add
Set sht2 = wb.ActiveSheet
For i = primeraFila To ultimaFila
sht1.Range("A" & i & ":C" & i).Copy
sht2.Range("B1").PasteSpecial Paste:=xlPasteAll, Transpose:=True
wb.SaveAs Filename:=RutaArchivo & NombreArchivo & "_" & i & ".xls", FileFormat:=xlNormal
Next i
wb.Close
MsgBox "Completado!"
Set sht2 = Nothing
Set sht1 = Nothing
Set wb = Nothing
End Sub