Tách 1 file n sheets thanh n files (1 người xem)

aladinh · 6/1/12

Mình đang cần tách 1 file có n sheets thành n files, với mỗi file là 1 sheet và tên file cũng là tên sheet đó luôn.
Mong anh chị em giúp đỡ nhé.

Hoàng Trọng Nghĩa · 6/1/12

aladinh đã viết:
Mình đang cần tách 1 file có n sheets thành n files, với mỗi file là 1 sheet và tên file cũng là tên sheet đó luôn.
Mong anh chị em giúp đỡ nhé.

Bạn thử với code này xem:

PHP:

Sub TaoFile()
    On Error Resume Next
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
        Dim MyFile As String, i As Long
        For i = 1 To Worksheets.Count
            Worksheets(i).Select
            MyFile = ActiveSheet.Name
            ActiveSheet.Copy
            With ActiveWorkbook
                .SaveAs Filename:=ThisWorkbook.Path & "\" & MyFile, FileFormat:=xlNormal
                .Close
            End With
        Next
     Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
     Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

nghiaphuc · 6/1/12

minhthien321 đã viết:

Bạn thử với code này xem:

PHP:

Sub TaoFile()
    On Error Resume Next
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
        Dim MyFile As String, i As Long
        For i = 1 To Worksheets.Count
            Worksheets(i).Select
            MyFile = ActiveSheet.Name
            ActiveSheet.Copy
            With ActiveWorkbook
                .SaveAs Filename:=ThisWorkbook.Path & "\" & MyFile, FileFormat:=xlNormal
                .Close
            End With
        Next
     Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
     Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Như vầy sẽ gọn gàng hơn một xíu nè anh:

PHP:

Sub Tao_File()
    Dim i As Byte
    For i = 1 To Sheets.Count
        Sheets(i).Copy
        With ActiveWorkbook
            .SaveAs ThisWorkbook.Path & "\" & .Sheets(1).Name
            .Close
        End With
    Next
End Sub

Hoàng Trọng Nghĩa · 6/1/12

nghiaphuc đã viết:
Như vầy sẽ gọn gàng hơn một xíu nè anh:

PHP:

Sub Tao_File() Dim i As Byte For i = 1 To Sheets.Count Sheets(i).Copy With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & .Sheets(1).Name .Close End With Next End Sub

Đúng là gọn hơn, nhưng vấn đề là không có những cái Application đó thì màn hình sẽ bị chớp, khi file trùng tên sẽ thông báo lỗi....

NghiaPhuc thử chạy code đó 2 lần thử xem sao!

nghiaphuc · 6/1/12

minhthien321 đã viết:
Đúng là gọn hơn, nhưng vấn đề là không có những cái Application đó thì màn hình sẽ bị chớp, khi file trùng tên sẽ thông báo lỗi....

NghiaPhuc thử chạy code đó 2 lần thử xem sao!

Đồng ý với anh. Như vậy thì lấy cái vòng For của em thay cho vòng For của anh sẽ đỡ được vài câu lệnh không cần thiết (chọn sheet, gán tên sheet cho biến MyFile)

Hoàng Trọng Nghĩa · 6/1/12

nghiaphuc đã viết:
Đồng ý với anh. Như vậy thì lấy cái vòng For của em thay cho vòng For của anh sẽ đỡ được vài câu lệnh không cần thiết (chọn sheet, gán tên sheet cho biến MyFile)

OK, vậy thì như vầy đi:

PHP:

Sub TaoFile()
    On Error Resume Next
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
        Dim i As Long
        For i = 1 To Sheets.Count
            Sheets(i).Copy
            With ActiveWorkbook
                .SaveAs ThisWorkbook.Path & "\" & .Sheets(1).Name
                .Close
            End With
        Next
     Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
     Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Mình thì chọn i as Long vì biết đâu nó hơn 256 sheet thì sao nhỉ (XL2007 trở lên)? Nếu là Byte thì sẽ báo lỗi

ndu96081631 · 6/1/12

minhthien321 đã viết:

OK, vậy thì như vầy đi:

PHP:

Sub TaoFile()
    On Error Resume Next
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
        Dim i As Long
        For i = 1 To Sheets.Count
            Sheets(i).Copy
            With ActiveWorkbook
                .SaveAs ThisWorkbook.Path & "\" & .Sheets(1).Name
                .Close
            End With
        Next
     Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
     Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Mình thì chọn i as Long vì biết đâu nó hơn 256 sheet thì sao nhỉ (XL2007 trở lên)? Nếu là Byte thì sẽ báo lỗi

Dùng biến Long là điều đương nhiên rồi, ai lại Byte hay Integer cho.. dở hơi
Ngoài ra: Cẩn thận với vụ copy sheet vì nó sẽ "mang theo" luôn Define name ---> Khi ấy sẽ rắc rối dài dài vì những liên kết ngoài file
Vậy nên tôi nghĩ hướng đi sẽ vầy:
- Copy sheet ra file mới
- Trên file mới này, ta copy UsedRange thành Values
- Xóa hết Define name
- Lưu và đóng file
- Ngoài ra, có thể thêm công đoạn kiểm tra sự tồn tại của FiileName (nếu tên file đã có, sao mà lưu?)
Thử lại xem

Hoàng Trọng Nghĩa · 6/1/12

ndu96081631 đã viết:
Dùng biến Long là điều đương nhiên rồi, ai lại Byte hay Integer cho.. dở hơi Ngoài ra: Cẩn thận với vụ copy sheet vì nó sẽ "mang theo" luôn Define name ---> Khi ấy sẽ rắc rối dài dài vì những liên kết ngoài file Vậy nên tôi nghĩ hướng đi sẽ vầy: - Copy sheet ra file mới - Trên file mới này, ta copy UsedRange thành Values - Xóa hết Define name - Lưu và đóng file - Ngoài ra, có thể thêm công đoạn kiểm tra sự tồn tại của FiileName (nếu tên file đã có, sao mà lưu?) Thử lại xem

Những phần trên phải thêm vào, hoàn toàn đúng, nhưng phần tô đậm, nếu mình chặn thông báo, tự động nó sẽ save chồng lên file cũ, nếu không chặn thông báo, nó sẽ tự báo nếu có file tồn tại, chỉ là chọn lựa save hay không mà thôi, vì em đã thử nhiều lần nên mới dám nói như vậy.

PHP:

Sub TaoFile()
    On Error Resume Next
    Application.ScreenUpdating = False: Application.EnableEvents = False
    Application.DisplayAlerts = False: Application.Calculation = xlCalculationManual
        Dim i As Long, MyName As Name
        For i = 1 To Sheets.Count
            Sheets(i).Copy
            With ActiveWorkbook
                With .Sheets(1)
                    .DrawingObjects.Delete
                    .Cells.Copy
                    .Cells.PasteSpecial 3
                    .Range("A1").Select
                    For Each MyName In .Names
                      MyName.Delete
                    Next
                End With
''                With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
''                  .DeleteLines 1, .CountOfLines
''                End With
                .SaveAs Filename:=ThisWorkbook.Path & "\" & .Sheets(1).Name, FileFormat:=xlNormal
                .Close
            End With
        Next
     Application.Calculation = xlCalculationAutomatic: Application.DisplayAlerts = True
     Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

xaque001 · 4/6/13

E có dánh sách như thế này muốn hỏi các anh:

khi điền danh sách vào sheet 'thdshs dự thi' thì căn cứ vào cột 'xã' nó sẽ tự sao chép sang các sheet có tên xã tương ứng. Xin nhờ các cao thủ trợ giúp
thank's!

Tách 1 file n sheets thanh n files (1 người xem)

Người dùng đang xem chủ đề này

aladinh

Thành viên mới

Hoàng Trọng Nghĩa

Chuyên gia GPE

nghiaphuc

Thành viên gạo cội

Hoàng Trọng Nghĩa

Chuyên gia GPE

nghiaphuc

Thành viên gạo cội

Hoàng Trọng Nghĩa

Chuyên gia GPE

ndu96081631

Huyền thoại GPE

Hoàng Trọng Nghĩa

Chuyên gia GPE

xaque001

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.