copy 8000 rows and paste in new workbook

[negi]

hi,
i am using excel 2007 and i have more then 200000 records in one sheet.now i want to copy 8000 records and paste in excel 2003 format and save it part 1.then next 8000 re copy and repeat same.
Please help ........

 

[John_w]

Try this, but first edit the code to test it on a small number of rows, by changing the lastRow and numRows lines, say lastRow = 100, numRows = 10. You will need to change the folder path in the SaveAs.

Sub Copy_8000()
    Dim r As Long, lastRow As Long, numRows As Long
    Dim part As Integer
    
    part = 0
    lastRow = 200000
    numRows = 8000
    For r = 1 To lastRow Step numRows
        part = part + 1
        Rows(r & ":" & r + numRows - 1).Copy
        Workbooks.Add
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs Filename:="C:\temp\excel\Part_" & part & ".xls", FileFormat:=xlExcel8
        ActiveWorkbook.Close savechanges:=False
    Next
    
End Sub

 

[negi]

Hi,
john Thanks.
But problem in Workbooks.Add
please help

 

[negi]

dear jhon one more help please
i want copy first heading in every workbook

 

[John_w]

But problem in Workbooks.Add

What is the exact error? The code works for me in Excel 2003 and 2007. Help yourself by recording a macro to create a new workbook to show the full syntax of Workbooks.Add and using that in my code.

Here is a new version which copies the column headings to each new workbook:

Sub Copy_8000B()

    Dim r As Long, lastRow As Long, numRows As Long
    Dim part As Integer
    Dim thisSheet As Worksheet
    
    lastRow = 200000
    numRows = 8000
    part = 0
    Set thisSheet = ActiveSheet
    
    For r = 2 To lastRow Step numRows
        part = part + 1
        Workbooks.Add
        thisSheet.Rows(1).Copy Rows(1)
        thisSheet.Rows(r & ":" & r + numRows - 1).Copy Rows(2)
        
        ActiveWorkbook.SaveAs Filename:="C:\temp\excel\Part_" & part & ".xls", FileFormat:=xlExcel8
        ActiveWorkbook.Close savechanges:=False
    Next
    
End Sub

 

[negi]

Thanks jhon...
its working... thanks so much