Đăng ký học Excel và VBA cùng GPE tháng 11 - TPHCM

Mua sách "VBA trong Excel - Cải thiện và tăng tốc" tái bản

Làm giảm dung lượng tập tin Excel

Thảo luận trong 'Thư viện mã lập trình' bắt đầu bởi levanduyet, 4 Tháng bảy 2011.

  1. levanduyet

    levanduyet Thành viên danh dự

    Sau khi sử dụng một thời gian, các bạn phát hiện tập tin Excel của mình có dung lượng lớn. Vậy làm sao để làm giảm dung lượng tập tin Excel này?
    Xin giới thiệu các bạn đoạn code của DRJ

    Mã:
    Option Explicit 
     
    Sub ExcelDiet() 
         
        Dim j               As Long 
        Dim k               As Long 
        Dim LastRow         As Long 
        Dim LastCol         As Long 
        Dim ColFormula      As Range 
        Dim RowFormula      As Range 
        Dim ColValue        As Range 
        Dim RowValue        As Range 
        Dim Shp             As Shape 
        Dim ws              As Worksheet 
         
        Application.ScreenUpdating = False 
        Application.DisplayAlerts = False 
         
        On Error Resume Next 
         
        For Each ws In Worksheets 
            With ws 
                 ' Tìm ô sử dụng cuối cùng với công thức và giá trị
                 ' Tìm theo cột và hàng
                On Error Resume Next 
                Set ColFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
                Set ColValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
                LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious) 
                Set RowFormula = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _ 
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
                Set RowValue = .Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, _ 
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious) 
                On Error Goto 0 
                 
                 ' Xác định cột cuối cùng
                If ColFormula Is Nothing Then 
                    LastCol = 0 
                Else 
                    LastCol = ColFormula.Column 
                End If 
                If Not ColValue Is Nothing Then 
                    LastCol = Application.WorksheetFunction.Max(LastCol, ColValue.Column) 
                End If 
                 
                 ' Xác định hàng cuối
                If RowFormula Is Nothing Then 
                    LastRow = 0 
                Else 
                    LastRow = RowFormula.Row 
                End If 
                If Not RowValue Is Nothing Then 
                    LastRow = Application.WorksheetFunction.Max(LastRow, RowValue.Row) 
                End If 
                 
                 ' Xác định xem có shapes nào nằm ngoài hàng cuối và cột cuối
                For Each Shp In .Shapes 
                    j = 0 
                    k = 0 
                    On Error Resume Next 
                    j = Shp.TopLeftCell.Row 
                    k = Shp.TopLeftCell.Column 
                    On Error Goto 0 
                    If j > 0 And k > 0 Then 
                        Do Until .Cells(j, k).Top > Shp.Top + Shp.Height 
                            j = j + 1 
                        Loop 
                        If j > LastRow Then 
                            LastRow = j 
                        End If 
                        Do Until .Cells(j, k).Left > Shp.Left + Shp.Width 
                            k = k + 1 
                        Loop 
                        If k > LastCol Then 
                            LastCol = k 
                        End If 
                    End If 
                Next 
                 
                .Range(Cells(1, LastCol + 1).Address & ":IV65536").Delete 
                .Range(Cells(LastRow + 1, 1).Address & ":IV65536").Delete 
            End With 
        Next 
         
        Application.ScreenUpdating = True 
        Application.DisplayAlerts = True 
         
    End Sub 
     
    
    Xin chú ý: các bạn phải UnHide các sheet trước khi thực hiện thủ tục này.

    Ngoài ra một cách hơi "cà chua" một tí là chuyển tập tin từ định dạng xls (Excel 2003 trở về trước) sang xlsx (Excel 2007 trở về sau).


    Lê Văn Duyệt
     

    Các file đính kèm:

    Lần chỉnh sửa cuối: 11 Tháng ba 2012

Chia sẻ trang này