Giúp Chia file excel thành nhiều file khác nhau (1 người xem)

[tungpheng]

Em có 1 file danh sách với số lượng hàng rất là lớn. em có gửi demo 1 danh sách có 200 hàng dữ liệu
giờ em muốn chia nó thành nhiều file theo số hàng mình yêu cầu.
VÍ du: file gốc là chia_danh_sach.xlsx
em muốn chia thành các file:
- chia_danh_sach_1.xlsx (từ hàng 1 - đến hàng 50)
- chia_danh_sach_2.xlsx (từ hàng 51 - đến hàng 100)
- ...

Mỗi file chứa 50 hàng lần lượt từ file danh sách tổng;
mọi người giúp em với ạ.

 

[befaint]

Bạn xem file đính kèm nhé...

 

[quanluu]

Em có 1 file danh sách với số lượng hàng rất là lớn. em có gửi demo 1 danh sách có 200 hàng dữ liệu
giờ em muốn chia nó thành nhiều file theo số hàng mình yêu cầu.
VÍ du: file gốc là chia_danh_sach.xlsx
em muốn chia thành các file:
- chia_danh_sach_1.xlsx (từ hàng 1 - đến hàng 50)
- chia_danh_sach_2.xlsx (từ hàng 51 - đến hàng 100)
- ...

Mỗi file chứa 50 hàng lần lượt từ file danh sách tổng;
mọi người giúp em với ạ.

Bạn thử code này

Sub tach()
Dim i As Integer, wb As Workbook, wbmain As Workbook
    Application.ScreenUpdating = False
    Set wbmain = ThisWorkbook
    For i = 1 To Range("A65000").End(3).Row Step 50
        Workbooks.Add
        wbmain.ActiveSheet.Range("A" & i & ":F" & i + 49).Copy Range("A1")
        ActiveWorkbook.Close True, wbmain.Path & "\chia_danh_sach_" & Int(i / 50) + 1, 51
    Next
    Application.ScreenUpdating = True
End Sub

 

[tungpheng]

cảm ơn bác em làm được rồi ạ.

Sub Tachfile() 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 = 10 'as your example, just 10 rows per file


'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

 

[tungpheng]

Bạn xem file đính kèm nhé...

cảm ơn bác nhiều ạ. cái này chuẩn quá rồi