I have an excel file with 5 different excel sheets(page1, page2, page3, page4, page5) in it. Each Sheet has a header as well. Each sheet has 160 ( it can vary but will be in multiple of 20 always) records. I want to create 8 different excel files with 20 records each with same 5 different sheets into it.

So basically it should just take 20 records from each sheet of of excel file and create excel file. 160 records / 20 = 8 files is the logic. I tried lot of things but couldn't find anything to split records into same number of excel sheets in excel file.

Output should be

1. File 1 (page1, page2, page3, page4, page5) with 20 first records in them
2. File 2 (page1, page2, page3, page4, page5) 21-40 records in them
3. File 3 (page1, page2, page3, page4, page5) 41-60 records in them
4. File 4 (page1, page2, page3, page4, page5) 61-80 records in them
5. File 5 (page1, page2, page3, page4, page5) 81-100 records in them and so on

I have tried below macro

Sub Test()
Dim wb As Workbook
Dim ThisSheet As Worksheet
Dim NumOfColumns As Integer
Dim RangeToCopy As Range
Dim RangeOfHeader As Range        'data (range) of header row
Dim WorkbookCounter As Integer
Dim RowsInFile                    'how many rows (incl. header) in 
new files?

Application.ScreenUpdating = False

'Initialize data
Set ThisSheet = ThisWorkbook.ActiveSheet
NumOfColumns = ThisSheet.UsedRange.Columns.Count
WorkbookCounter = 1
RowsInFile = 20                   '20 rows and 1 header

'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 "MyTest" & WorkbookCounter & ".xlsx", FileFormat:=51
wb.Close

'Increment file counter
WorkbookCounter = WorkbookCounter   1
Next p

Application.ScreenUpdating = True
Set wb = Nothing
End Sub

I am stuck at a point where I am not able to understand how do I split excel with multiple sheets into same number of sheets into new excel by set row count. i.e. 20.

For example in code Set ThisSheet = ThisWorkbook.ActiveSheet //here actually all sheets in excel should get selected and macro should create 20 records each for each sheet in an excel into new excel file with same number of sheets. Humble request to help me.

CodePudding user response：

Loop through the sheets appending the records.

Option Explicit

Sub Test()
    Dim wb As Workbook
    Dim ThisSheet As Worksheet, ws As Worksheet
    Dim NumOfColumns As Integer, WorkbookCounter As Integer, p As Long
    Dim RangeToCopy As Range, RangeOfHeader As Range 'data (range) of header row
   
    Application.ScreenUpdating = False
    Set ThisSheet = ThisWorkbook.ActiveSheet

    'Initialize data
    NumOfColumns = ThisSheet.UsedRange.Columns.Count
    WorkbookCounter = 1
    Const RowsInFile = 20   '20 rows and 1 header
    
    'Copy the data of the first row (header)
    Set RangeOfHeader = ThisSheet.UsedRange.Rows(1)
    
    For p = 2 To ThisSheet.UsedRange.Rows.Count Step RowsInFile
        Set wb = Workbooks.Add(xlWBATWorksheet)
        
        'Paste the header row in new file
        RangeOfHeader.Copy wb.Sheets(1).Range("A1")
        
        For Each ws In ThisWorkbook.Sheets
            'Paste the chunk of rows for this file
            Set RangeToCopy = ws.Range("A" & p).Resize(RowsInFile, NumOfColumns)
            RangeToCopy.Copy wb.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
        Next
        'Save the new workbook, and close it
        
        wb.SaveAs "MyTest" & WorkbookCounter & ".xlsx", FileFormat:=51
        wb.Close
        
        'Increment file counter
        WorkbookCounter = WorkbookCounter   1
    Next p
    
    Application.ScreenUpdating = True
    Set wb = Nothing
End Sub

CodePudding user response：

That would be my suggestion

Option Explicit

Function rgToCopy(ws As Worksheet, startRow As Long, noRows As Long, noCols As Long) As Range

    Dim rg As Range
    
    With ws
        Set rg = ws.Range(.Cells(startRow, 1), .Cells(startRow   noRows - 1, 1))
    End With
    
    Set rgToCopy = rg.Columns("A:" & columnLetter(noCols))
    
End Function

Function columnLetter(columnNumber As Long) As String
    columnLetter = Split(Cells(1, columnNumber).Address, "$")(1)
End Function


Sub CopyData()

    Dim i As Long
    Dim rg As Range
    Dim noOfRows As Long
    Dim NumOfColumns  As Long
    
    NumOfColumns = 2  ' Adjust to your needs
    noOfRows = 10     ' Adjust to your needs
    
    Dim shName As Variant
    Dim sheetNames As Variant
    Dim wks As Worksheet
    Dim wkb As Workbook
    
    sheetNames = Array("Tabelle1", "Tabelle2")  ' Adjust to your needs
    
    For i = 2 To 161 Step noOfRows    ' Adjust the 161 to your needs
        
        ' create new workbook
        Set wkb = Workbooks.Add
        ' add header <= not done
        
        Dim j As Long: j = 2
        
        For Each shName In sheetNames
            Set wks = ThisWorkbook.Sheets(shName)
            Set rg = rgToCopy(wks, i, noOfRows, NumOfColumns)
            rg.Copy
            wkb.Sheets(1).Paste Range("A" & j)
            j = j   noOfRows
        Next shName
        
        ' save and close workbook
        wkb.SaveAs ThisWorkbook.Path & "\" & i  ' Adjust to your needs
        wkb.Close False
        
    Next i
        
End Sub

Please note that I did not copy the header, that is left to you.