Separar base de datos Excel en archivos independientes
Para solicitar de su apoyo con el siguiente caso: Tengo una pequeña base de datos en excel la cual debo dividir en 3,4 o 5 partes (según sea necesario)y guardar cada bloque en un archivo diferente con la teminacion de un consecutivo para que no se sobreescriban, el problema en resumen es que el resultado de la división de los renglones en muchas ocasiones no es un numero entero y lo que busco es que si los registros por ejemplo: son 17 y lo quiero dividir en 3 partes me genere 3 archivos.
El primero y segundo de 5 renglones y el tercero de 7 es decir que en el archivo final ponga el resto de los renglones. El código que tengo ya hace la correcta división sin embargo me genera un 4 archivo con los 2 registros sobrantes. Mucho agradezco el apoyo que me puedan brindar.. Adjunto código y archivo de ejemplo.
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim RangeOfHeader As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 5 'ejemplo 5 renglones por archivo incluyen el encabezado
'Copy the data of the first row (header)
Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))
For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the header row in new file
RangeOfHeader.Copy wb.Sheets(1).Range("A1")
'Paste the chunk of rows for this file
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A2")
'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "\test" & WorkbookCounter
wb.Close
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
1 Respuesta
Te agrego unas líneas a tu código:
Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim RangeOfHeader As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Application.ScreenUpdating = False
'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 5 'ejemplo 5 renglones por archivo incluyen el encabezado
'Copy the data of the first row (header)
Set RangeOfHeader = ThisSheet.Range(ThisSheet.Cells(1, 1), ThisSheet.Cells(1, NumOfColumns))
For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile - 1
Set wb = Workbooks.Add
'Paste the header row in new file
RangeOfHeader.Copy wb.Sheets(1).Range("A1")
'----------Paste the chunk of rows for this file
x = ThisSheet.UsedRange.Rows.Count 'guarda la última fila del rango
If p + RowsInFile - 2 > x - RowsInFile + 1 Then
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(x, NumOfColumns))
p = x 'para salir del bucle
Else
Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 2, NumOfColumns))
End If
'--------------------
RangeToCopy.Copy wb.Sheets(1).Range("A2")
'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "\test" & WorkbookCounter
wb.Close
'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p
Application.ScreenUpdating = True
Set wb = Nothing
End Sub
