Nhờ sửa code VBA tách 1 file exel thành nhiều file nhỏ bằng autofilter

[le thi thuy 3013]

Chào mọi người,
Mình đang cần tách sheet "Total" thành các file nhỏ và tự động lưu thành các file mới
Ý tưởng: tạo thêm 1 sheet mới chứa điều kiện lọc theo tên Sale rồi dùng autofilter. Code phía dưới mình chạy toàn ra file chưa mỗi dòng tiêu đề. Nhờ mn xem và sửa giúp mình ạ

Sub taods()

Dim i As Integer

i = 2

With ThisWorkbook.Sheets("Assign")

While (.Cells(i, 1) <> "")

ThisWorkbook.Sheets("Total").Select

ActiveSheet.Range("A1", Sheets("Total").Range("H" & Rows.Count).End(xlUp)).AutoFilter Field:=2, Criteria1:=".Cells(i,1)"

Sheets("Total").Range("A:H").Select

Selection.Copy

Sheets("Data").Paste

Sheets("Total").Range("A1", Sheets("Total).Range("H" & Rows.Count).End(xlUp)).AutoFilter

ThisWorkbook.Sheets("Data").Copy

ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Danh Sach\" & .Cells(i, 1) & ".xlsx"

i = i + 1

Wend

End With

End Sub

 

[HUONGHCKT]

Chào mọi người,
Mình đang cần tách sheet "Total" thành các file nhỏ và tự động lưu thành các file mới
Ý tưởng: tạo thêm 1 sheet mới chứa điều kiện lọc theo tên Sale rồi dùng autofilter. Code phía dưới mình chạy toàn ra file chưa mỗi dòng tiêu đề. Nhờ mn xem và sửa giúp mình ạ

Bỏ dấu "

Criteria1:=".Cells(i,1)"

Thành

Criteria1:=.Cells(i,1)

Hãy thử xem.

 

[le thi thuy 3013]

Bỏ dấu "

Thành

Hãy thử xem.

Mình đã thử. Run được rồi nhưng biến i không tăng,chỉ tạo được duy nhất 1 file nhỏ chứa tên sale thứ 1 thôi bạn

 

[HUONGHCKT]

Mình đã thử. Run được rồi nhưng biến i không tăng,chỉ tạo được duy nhất 1 file nhỏ chứa tên sale thứ 1 thôi bạn

Bạn thử thay vòng lặp for next xem sao.

 

[Maika8008]

Tất cả các sheet đều có địa chỉ, tự nhiên có 1 câu lệnh trỏ ActiveSheet. Xem lại chỗ đó đi.

 

[le thi thuy 3013]

Em thử mấy nữa cũng k được, mà code trên vẫn tạo được file mới chỉ là không chạy tiếp vòng lặp nên em nghĩ câu lệnh chứa ActiveSheets kia k có vấn đề đâu ạ. phiền mọi người ai có giải pháp cho em xin với ạ. Em cảm ơn

 

[ptm0412]

Thêm câu lệnh
ActiveWorkbook.Close
trước dòng
i = i + 1
Lý do: File mới lưu là file hiện hành, không thể quay sang select sheet Total của file khác được.

Còn nữa:
Câu lệnh Sheets("Data").Paste bị lỗi vì không phải sheet hiện hành. Hãy copy kiểu Copy + Destination thay vì Copy + Paste
Copy nguyên 8 cột (8 triệu ô)
Không cần select cũng copy được nếu chỉ định rõ địa chỉ
Chạy code thì màn hình giật giật.
Cần xóa dữ liệu cũ ở sheet Data trước khi copy dữ liệu mới vào.
Code như sau đây chạy đỡ hơn dù chưa tối ưu

Sub taods()
Dim i As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i = 2
With ThisWorkbook.Sheets("Assign")
    While (.Cells(i, 1) <> "")
        Sheets("Data").Range("A1:H1000").ClearContents
        Sheets("Total").Range("A1", Sheets("Total").Range("H" & Rows.Count).End(xlUp)).AutoFilter _
        Field:=2, Criteria1:=.Cells(i, 1)
        Sheets("Total").Range("A1", Sheets("Total").Range("H" & Rows.Count).End(xlUp)).Copy Sheets("Data").[A1]
        ThisWorkbook.Sheets("Data").Copy
       
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & .Cells(i, 1) & ".xlsx"
        ActiveWorkbook.Close
        i = i + 1
    Wend
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

 

[ptm0412]

Tất cả các sheet đều có địa chỉ, tự nhiên có 1 câu lệnh trỏ ActiveSheet. Xem lại chỗ đó đi.

"Chỗ đó" không làm sao cả vì phía trên đã select sheet Total. Vấn đề nằm ở chính câu lệnh Select sheet total: ThisWorkbook không phải activeWorkbook thì không select sheet được.

 

[ptm0412]

Sử dụng Advanced Filter nhanh gấp 7 lần Copy paste

Sub TaoFile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i = 2
t = Timer
Sheets("Total").AutoFilterMode = False
With ThisWorkbook.Sheets("Assign")
    While (.Cells(i, 1) <> "")
        Sheets("Data").[L2] = .Cells(i, 1)
        LastRw = Sheets("Total").[H20000].End(xlUp).Row
        Sheets("Total").Range("A1:H" & LastRw).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Data").[L1:L2], CopyToRange:=Sheets("Data").[A1:H1]
        ThisWorkbook.Sheets("Data").Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & .Cells(i, 1) & ".xlsx"
        ActiveWorkbook.Close
        i = i + 1
    Wend
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox Timer - t
End Sub

 

[le thi thuy 3013]

Sử dụng Advanced Filter nhanh gấp 7 lần Copy paste

Sub TaoFile()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
i = 2
t = Timer
Sheets("Total").AutoFilterMode = False
With ThisWorkbook.Sheets("Assign")
    While (.Cells(i, 1) <> "")
        Sheets("Data").[L2] = .Cells(i, 1)
        LastRw = Sheets("Total").[H20000].End(xlUp).Row
        Sheets("Total").Range("A1:H" & LastRw).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Data").[L1:L2], CopyToRange:=Sheets("Data").[A1:H1]
        ThisWorkbook.Sheets("Data").Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & .Cells(i, 1) & ".xlsx"
        ActiveWorkbook.Close
        i = i + 1
    Wend
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox Timer - t
End Sub

Bạn ơi, mình có cần clear content ở sheet Data sau mỗi lần paste k, vì mình sợ sẽ bị ghi đè giá trị cũ trước đó nếu số dòng ít hơn chẳng hạn?

 

[ptm0412]

Bạn ơi, mình có cần clear content ở sheet Data sau mỗi lần paste k, vì mình sợ sẽ bị ghi đè giá trị cũ trước đó nếu số dòng ít hơn chẳng hạn?

Có chứ. Code bài 7 tôi có bổ sung, bài 9 thì quên.

 

[le thi thuy 3013]

Có chứ. Code bài 7 tôi có bổ sung, bài 9 thì quên.

Cảm ơn bạn nhiều nhé

 

[ptm0412]

Cảm ơn bạn nhiều nhé

Thế bạn đã đăng ký tham dự sinh nhật GPE chưa?