kiến thức [Excel VBA] Tách từng sheet trong một file Excel thành một file riêng lẻ

NguyenDang95 said:

Đổi tên được mà thím.
View attachment 1013423

Click to expand...

"build thêm add-in tạo nhanh Filter" cái này thím giải thích rõ hơn được không.

Click to expand...

GR666N said:

Mình biết cách rename mà, chủ yếu là để mọi người dễ dùng hơn, với cả lúc cài lại đỡ phải vô thớt tra lại tên macro

Click to expand...

GR666N said:

Chức năng tạo bộ lọc Filter ở tab DATA á thym. Ý tưởng cũng na ná tạo PrintTitle, cũng chọn sheet, nhập vùng filter (vd $A$1:$K999) rùi bấm [chạy] là các sheet đều có bộ lọc luôn

Click to expand...

NguyenDang95 said:

Thím mở Tab Developer, chọn Visual Basic (hoặc Alt+F11), nhấp chọn macro rồi đổi tên trong mục (Name) là được.
View attachment 1013820

Có thêm điều kiện gì không thím hay là chỉ bật Filter mặc định thôi.

Click to expand...

GR666N said:

[

Chỉ cần tạo filter cho nhiều sheet cùng lúc là đc thym, tiện thì build luôn cái đóng băng hàng-cột (freeze panel) cho đủ bộ, cái này mình ít xài nhưng thấy nhiều người dùng phết
Ý tưởng vẫn là chọn các sheet cần freeze, chọn vị trí đóng băng (vd B5) -> cột A và các hàng 1,2,3,4 sẽ bị đóng băng)

P/s: thym thiết kế thành add-in 3 in1 (print tit + filter + freeze) thì quá ngon :s

Click to expand...

NguyenDang95 said:

Đây nhé thím
View attachment 1014205

Click to expand...

GR666N said:

cho mình hỏi ngu tý, tên macro là gì vậy ợ
View attachment 1015732

Click to expand...

NguyenDang95 said:

ShowFrm đó thím, thím nhấn Alt+F11, tìm module tên m_ShowUserForm, rồi sửa tên bôi đen trong hình cho dễ mò nha bác (em quên không đổi tên ).
View attachment 1015748

Click to expand...

GR666N said:

lỗi ko chạy được thym ơi View attachment 1015762

Update: mình test thử bằng Alt+F11 + F5 thấy chức năng tạo PrintTit ok, đóng băng ok (có thêm phá băng nhanh thì tốt), riêng Filter thì chỉ đặt vùng lọc được 1 lần (ví dụ đặt sai vùng lọc là $A$5:$K$9999, muốn đổi thành $A$6:$K$9999 thì phải làm thủ công hoặc phá lọc từng sheet rùi chạy lại )

Click to expand...

GR666N said:

lỗi ko chạy được thym ơi View attachment 1015762

Update: mình test thử bằng Alt+F11 + F5 thấy chức năng tạo PrintTit ok, đóng băng ok (có thêm phá băng nhanh thì tốt), riêng Filter thì chỉ đặt vùng lọc được 1 lần (ví dụ đặt sai vùng lọc là $A$5:$K$9999, muốn đổi thành $A$6:$K$9999 thì phải làm thủ công hoặc phá lọc từng sheet rùi chạy lại )

Click to expand...

NguyenDang95 said:

Gửi thím file Add-in nhé.
Cái Filter bị lỗi do em quên không kiểm tra hết tất cả các điều kiện có thể xảy ra với lại không tìm hiểu kỹ thằng AutoFilter hoạt động ra sao trong VBA:
Tài liệu của Microsoft:
https://docs.microsoft.com/en-us/office/vba/api/excel.range.autofilter

Cái UserForm em có bổ sung thêm vài nút bấm như "Xóa Filter", "Hủy đóng băng" để bác tiện dùng .
View attachment 1016309
View attachment 1016312

Click to expand...

NguyenDang95 said:

Chào mọi người. Trong quá trình làm việc, một số người dùng muốn tách từng sheet trong một file Excel thành một file riêng lẻ để phục vụ nhiều mục đích khác nhau. Nếu file có vài ba sheet cần tách thì có thể thao tác thủ công, nhưng nếu có vài chục sheet cần tách thì lúc này macro sẽ giúp chúng ta giải quyết việc này một cách nhanh chóng.
Macro dưới đây sẽ:

• Đọc từng sheet trong file Excel cần thao tác.
• Dùng phương thức Sheets.Copy sẽ khiến Excel tạo một workbook riêng chứa sheet đang đọc
• Lưu workbook mới vừa tạo với tên sheet đang đọc, sau đó đóng workbook mới đó

Code:

Option Explicit

Private Sub ExportMultipleSheets()
    Dim objWb As Excel.Workbook
    Dim objNewWb As Excel.Workbook
    Dim objSheets As Excel.Sheets
    Dim objSheet As Excel.Worksheet
    Dim objNewSheet As Excel.Worksheet
    Dim strExportFolder As String
    Dim strSheetName As String
    Dim lngSheetCount As Long
   
    strExportFolder = "C:\ExportFolder\" 'Thư mục xuất file ra
    lngSheetCount = 0
    Set objWb = ActiveWorkbook
    Set objSheets = objWb.Sheets
    For Each objSheet In objSheets
        strSheetName = strExportFolder & objSheet.Name & ".xlsx"
        objSheet.Copy
        Set objNewWb = ActiveWorkbook
        Set objNewSheet = objNewWb.ActiveSheet
        objNewSheet.SaveAs Filename:=strSheetName, FileFormat:=xlOpenXMLWorkbook
        objNewWb.Close SaveChanges:=False
        strSheetName = ""
        lngSheetCount = lngSheetCount + 1
    Next objSheet
    MsgBox lngSheetCount & " sheet(s) exported successfully.", vbInformation, "Export Complete"
    Set objSheets = Nothing
    Set objSheet = Nothing
    Set objNewSheet = Nothing
    Set objWb = Nothing
    Set objNewWb = Nothing
End Sub

Ngoài cách viết macro và chạy trực tiếp trên file Excel, chúng ta có thể viết script VBScript để thao tác với file Excel.
Soạn thảo trong Notepad, lưu lại với phần mở rộng ".vbs".

View attachment 1009442

Code:

Option Explicit
   
    Dim objXl 'As Excel.Application
    Dim objWb 'As Excel.Workbook
    Dim objNewWb 'As Excel.Workbook
    Dim objSheets 'As Excel.Sheets
    Dim objSheet 'As Excel.Worksheet
    Dim objNewSheet 'As Excel.Worksheet
    Dim strExportFolder, strSheetName, strWbName 'As String
    Dim lngSheetCount 'As Long
    Const xlOpenXMLWorkbook = 51
   
    strExportFolder = "C:\ExportFolder\"
    strWbName = strExportFolder & "Book1.xlsm"
    lngSheetCount = 0
    Set objXl = CreateObject("Excel.Application")
    objXl.Visible = True
    Set objWb = objXl.Workbooks.Open(strWbName)
    Set objSheets = objWb.Sheets
    For Each objSheet In objSheets
        strSheetName = strExportFolder & objSheet.Name & ".xlsx"
        objSheet.Copy
        Set objNewWb = objXl.ActiveWorkbook
        Set objNewSheet = objNewWb.ActiveSheet
        objNewSheet.SaveAs strSheetName, xlOpenXMLWorkbook
        objNewWb.Close False
        strSheetName = ""
        lngSheetCount = lngSheetCount + 1
    Next
    objXl.Quit
    MsgBox lngSheetCount & " sheet(s) exported successfully.", vbInformation, "Export Complete"
    Set objXl = Nothing
    Set objSheets = Nothing
    Set objSheet = Nothing
    Set objNewSheet = Nothing
    Set objWb = Nothing
    Set objNewWb = Nothing

Kết quả:

View attachment 1009441

Click to expand...