Crear archivo con la misma estructura Excel
Tengo una macro para copiar de un libro a otro una fila, y copie 200 filas mas y cada fila es un libro diferente. Lo hace perfecto. Ahora necesito que dentro de cada archivo que he creado, deje en la columna A unos títulos que siempre son los mismos, es decir en la columna A debe ir siempre esto
CED
NOM
APE.
La macro que tengo es la siguiente:
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
2 Respuestas
Antes del 'next' escribe el código para ponerlo, puede ser en un rango específico o tú lo determinarás ya que no entiendo si es en la columna completa...
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
'Escribir
Range("A1").formula = "=CED"
Next
End SubTú corriges el rango en donde lo va a escribir, ojalá te sirva y no olvides votar.
Debes hacerlo antes de cerrar el libro.
Primero debes pegar los valores que están en memoria, porque de lo contrario se perderían; y después poner los títulos:
Sub Macro1()
'Por Dante Amor
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
.Range("A1:A3").Value = Application.Transpose(Array("CED", "NOM", "APE"))
l2.SaveAs RutaArchivo & .Range("B1").Value & ".xls", xlNormal
l2.Close False
End With
Next
End SubTambién puedes utilizar la siguiente opción, es más rápida, ya que no copia-pega, solamente pasa los valores.
Sub Macro2()
'Por Dante Amor
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
Set l2 = Workbooks.Add
With l2.Sheets(1)
.Range("A1:A3").Value = Application.Transpose(Array("CED", "NOM", "APE"))
.Range("B1:B3").Value = Application.Transpose(sh.Range("A" & i & ":C" & i).Value)
l2.SaveAs RutaArchivo & .Range("B1").Value & ".xls", xlNormal
l2.Close False
End With
Next
End Sub
Gracias Dante por tu respuesta
Y como podría reemplazar,
("CED", "NOM", "APE")si tengo lo que necesito copiar en la hoja2, es decir, como son más campos, los tengo listados en la hoja2, que me copiara la columna de a hoja2 a la de cada libro.
Gracias
Deberías ser más específica. Es decir, cuáles celdas de la hoja2 quieres copiar.
Te pongo un ejemplo:
Sub Macro2()
'Por Dante Amor
Dim RutaArchivo As String
Dim sh1 As Worksheet, sh2 As Worksheet
Dim l2 As Workbook
Dim i As Long
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'
Set sh1 = Sheets("Hoja1")
Set sh2 = Sheets("Hoja2")
RutaArchivo = "C:\Users\Usuario\Documents\Pruebas\"
'
For i = 2 To sh1.Range("A" & Rows.Count).End(3).Row
Set l2 = Workbooks.Add
With l2.Sheets(1)
.Range("A1:A3").Value = sh2.Range("A1:A3").Value
.Range("B1:B3").Value = Application.Transpose(sh1.Range("A" & i & ":C" & i).Value)
l2.SaveAs RutaArchivo & .Range("B1").Value & ".xls", xlNormal
l2.Close False
End With
Next
End Sub[No olvides valorar. Grs