Generar archivos distribuyendo el original
Alguien me podría ayudar con una macro que realice el siguiente proceso, estaría muy agradecido:
Ejemplo del nombre de mi archivo "123ABC34500".
1. Tengo un archivo el cual puede puede variar los rangos con datos y quisiera que según la cantidad de registros o filas que tenga la cual puede variar lo divida en n cantidad de archivos nuevos.
2. Cada archivo nuevo debe tener n cantidad de registros o filas.
Ejemplo si el archivo original tiene 1000 registros o filas, indicarle a la macro en cuantas partes debe dividir el archivo original, si le indico 5, cree 5 archivos con 200 registros cada uno.
3. Los archivos generados se deben nombrar consecutivamente según el nombre del archivo original, ejemplo:
123ABC34501
123ABC34502
123ABC34503
123ABC34504
123ABC34505
O podría ser,
123ABC34500_1
123ABC34500_2
123ABC34500_3
123ABC34500_4
123ABC34500_5
Teniendo en cuenta que el archivo original tiene números y letras en el centro.
1 Respuesta
H o l a: Ejecuta la siguiente macro en el archivo que quieres dividir los datos. Cambia en la macro "Hoja1" por el nombre de la hoja que contiene los datos.
Cuando ejecutes la macro te pedirá el número de archivos.
Sub GenerarArchivos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1")
num = InputBox("Escribe el número de archivos", "DIVIDIR INFORMACIÓN")
If num = "" Then Exit Sub
'
ruta = l1.Path & "\"
nombre = Left(l1.Name, InStrRev(l1.Name, ".") - 1)
n = 1
u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row
filas = WorksheetFunction.RoundUp(u / num, 0)
For i = 1 To u Step filas
Set l2 = Workbooks.Add
Set h2 = l2.Sheets(1)
h1.Rows(i & ":" & i + filas - 1).Copy h2.Range("A1")
l2.SaveAs Filename:=ruta & nombre & "_" & n & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close
n = n + 1
Next
MsgBox "Fin"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Muy buenas noches Dante,
Mil Gracias, no dejo de asombrarme con todos los procesos que haces, he utilizado varias de tus macros, son muy buenas y trato de aprender pero en cosas como estas la verdad no llego hasta allá.
Respecto a el código corre perfectamente, pero olvide especificar que cada archivo generado debe llevar la misma plantilla del original, es decir la fila 1 del original debe quedar en todos los archivos generados, sino es mucho pedir me podrías ayudar con este cambio o indicar que debo modificar en el código.
De nuevo gracias por la ayuda me sera de gran ayuda en mi trabajo.
Te anexo la actualización:
Sub GenerarArchivos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("Hoja1")
num = InputBox("Escribe el número de archivos", "DIVIDIR INFORMACIÓN")
If num = "" Then Exit Sub
'
ruta = l1.Path & "\"
nombre = Left(l1.Name, InStrRev(l1.Name, ".") - 1)
n = 1
u = h1.UsedRange.Rows(h1.UsedRange.Rows.Count).Row
filas = WorksheetFunction.RoundUp(u / num, 0)
For i = 2 To u Step filas
Set l2 = Workbooks.Add
Set h2 = l2.Sheets(1)
h1.Rows(1).Copy h2.Rows(1)
h1.Rows(i & ":" & i + filas - 1).Copy h2.Range("A2")
l2.SaveAs Filename:=ruta & nombre & "_" & n & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
l2.Close
n = n + 1
Next
MsgBox "Fin"
End Sub
