how to split data into multiple workbook with hearder

[Learning1]

Hi All,

I need some help with how to transfer data into multiple workbook with header . I have macro which split the data but don't bring the header into workbook 2 and workbook3 and etc and I like to do that please. Below data is little sample but I have 100K of rows and bigger header name.. I just want to bring 8000 rows to each new workbook with same header.. as you can see th macro does that but not able to bring header along with it. thanks for your help!

Example below of the data:

Change Type (Action)	Adjustment Type	Adjustment Code	Transaction Type	Transaction Usage Code	Transaction Type Code	Transaction Number
AL	MANUAL	RESTATE-TCV-ACV	MANUAL	R	B	2160036703
AL	MANUAL	RESTATE-TCV-ACV	MANUAL	R	B	2160028613
AL	MANUAL	RESTATE-TCV-ACV	MANUAL	R	B	2160017970
AL	MANUAL	RESTATE-TCV-ACV	MANUAL	R	B	2160018550
AL	MANUAL	RESTATE-TCV-ACV	MANUAL	R	B	2160029053

<colgroup><col span="6"><col></colgroup><tbody>
</tbody>

macro code:

Sub breakfiles()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim WorkbookCounter As Integer
Dim RowsInFile
Dim Prefix As String
'Const header_Row = 1

Application.ScreenUpdating = False

'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 8000 'how many rows (incl. header) in new files?
Prefix = "test" 'prefix of the file name

For p = 1 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
Set wb = Workbooks.Add

'Paste the chunk of rows for this file

Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells(p, 1), ThisSheet.Cells(p + RowsInFile - 1, NumOfColumns))
RangeToCopy.Copy wb.Sheets(1).Range("A1")

'Save the new workbook, and close it
wb.SaveAs ThisWorkbook.Path & "" & Prefix & "_" & WorkbookCounter
wb.Close

'Increment file counter
WorkbookCounter = WorkbookCounter + 1
Next p

Application.ScreenUpdating = True
Set wb = Nothing
End Sub

 

[igold]

Hi Learning1

Welcome to the MrExcel board.

I have not stepped through your code or really looked hard at it. That said, what would happen if you changed this line

Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells([COLOR=#ff0000]p[/COLOR], 1), ThisSheet.Cells([COLOR=#ff0000]p[/COLOR] + RowsInFile - 1, NumOfColumns))

to this

Set RangeToCopy = ThisSheet.Range(ThisSheet.Cells([COLOR=#ff0000]1[/COLOR], 1), ThisSheet.Cells([COLOR=#ff0000]1[/COLOR] + RowsInFile - 1, NumOfColumns))

 

[smozgur]

Hi Learning1,

Welcome to MrExcel.com!

I preferred to rewrite my version, so it might look different than yours. You can adapt yours accordingly if you like, this is just to give the idea.
It simply copies the first row into the new workbook first, then copies the necessary range defined with the row count by using limit variable.

Sub doSplitRows()
Dim sht As Worksheet
Dim head As Range
Dim rng As Range
Dim limit As Integer
Dim cll As Range
Dim wrk As Workbook
Dim prefix As String
Dim i As Integer


    Application.ScreenUpdating = False


    'Workbook filename prefix
    prefix = "test"


    'Number of rows to create a new workbook
    limit = 8000


    Set sht = ActiveSheet
    Set head = sht.Rows(1)
    Set cll = sht.Cells(2, 1)
    Do Until cll.Value = ""
        i = i + 1
        Set rng = cll.Resize(limit, cll.End(xlToRight).Column)
        Set wrk = Application.Workbooks.Add
        head.Copy wrk.Worksheets(1).Cells(1, 1)
        rng.Copy wrk.Worksheets(1).Cells(2, 1)
        wrk.SaveAs ThisWorkbook.Path & Application.PathSeparator & prefix & "_" & Format(i, "0000") 'Trying to make filename zero padded
        wrk.Close
        Set cll = cll.Offset(limit)
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

 

[Learning1]

Hi Learning1,

Welcome to MrExcel.com!

I preferred to rewrite my version, so it might look different than yours. You can adapt yours accordingly if you like, this is just to give the idea.
It simply copies the first row into the new workbook first, then copies the necessary range defined with the row count by using limit variable.

Sub doSplitRows()
Dim sht As Worksheet
Dim head As Range
Dim rng As Range
Dim limit As Integer
Dim cll As Range
Dim wrk As Workbook
Dim prefix As String
Dim i As Integer


    Application.ScreenUpdating = False


    'Workbook filename prefix
    prefix = "test"


    'Number of rows to create a new workbook
    limit = 8000


    Set sht = ActiveSheet
    Set head = sht.Rows(1)
    Set cll = sht.Cells(2, 1)
    Do Until cll.Value = ""
        i = i + 1
        Set rng = cll.Resize(limit, cll.End(xlToRight).Column)
        Set wrk = Application.Workbooks.Add
        head.Copy wrk.Worksheets(1).Cells(1, 1)
        rng.Copy wrk.Worksheets(1).Cells(2, 1)
        wrk.SaveAs ThisWorkbook.Path & Application.PathSeparator & prefix & "_" & Format(i, "0000") 'Trying to make filename zero padded
        wrk.Close
        Set cll = cll.Offset(limit)
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

Thank so much that worked awesomely!! thank you!

 

[Learning1]

sorry it was copying the same data over and over..however, it did bring header into files.. thank you for your response and help!

 

[Learning1]

Sorry it was copying the same data over and over but did bring header into other books.. Thanks for your response and help!

 

[igold]

Yeah it was just a quick glance. Afterwards I went back and tested it and saw the same thing. I am glad that smozgur was able to provide you with something that works.

Thanks for the feedback.

 

[smozgur]

Thank so much that worked awesomely!! thank you!

Glad to hear helps!