VBA Excel - Reduzindo o tamanho das suas planilhas - SHRINK REDUCE EXCEL FILE SIZE

Termo de Responsabilidade 

Suponha que ao receber um arquivo ele tivesse uns poucos Kbytes ou não mais do que algo entre 5 ou 6 MBytes. Aí, você efetuou algumas alterações pequenas, insignificantes, e salvou-o novamente na sua pasta. Neste momento você tem uma grande surpresa. Descobre que o tamanho da sua planilhas foi multiplicado entre 3 a 100 vezes mais!

Sim, isso é possível de acontecer no MS Excel.

Option Explicit

Sub SHRINK_EXCEL_FILE_SIZE()

    Dim WSheet As Worksheet

    Dim CSheet As String 'New Worksheet

    Dim OSheet As String 'Old WorkSheet

    Dim Col As Long

    Dim ECol As Long 'Last Column

    Dim lRow As Long

    Dim BRow As Long 'Last Row

    Dim Pic As Object

   

    For Each WSheet In Worksheets

        WSheet.Activate

         'Put the sheets in a variable to make it easy to go back and forth

        Let CSheet = WSheet.Name

         'Rename the sheet to its name with _Delete at the end

        

Let 

OSheet = CSheet & "_Delete"

        

Let 

WSheet.Name = OSheet

         'Add a new sheet and call it the original sheets name

        Sheets.Add

        

Let 

ActiveSheet.Name = CSheet

        Sheets(OSheet).Activate

   

        'Find the bottom cell of data on each column and find the further row

        For Col = 1 To Columns.Count 'Find the actual last bottom row

            If Cells(Rows.Count, Col).End(xlUp).Row > BRow Then

                

Let 

BRow = Cells(Rows.Count, Col).End(xlUp).Row

            End If

        Next

       

        'Find the end cell of data on each row that has data and find the furthest one

        For lRow = 1 To BRow 'Find the actual last right column

            If Cells(lRow, Columns.Count).End(xlToLeft).Column > ECol Then

                

Let 

ECol = Cells(lRow, Columns.Count).End(xlToLeft).Column

            End If

        Next

       

        'Copy the REAL set of data

        Range(Cells(1, 1), Cells(BRow, ECol)).Copy

        Sheets(CSheet).Activate

        'Paste Every Thing

        Range("A1").PasteSpecial xlPasteAll

        'Paste Column Widths

        Range("A1").PasteSpecial xlPasteColumnWidths

        Sheets(OSheet).Activate

        For Each Pic In ActiveSheet.Pictures

            Pic.Copy

            Sheets(CSheet).Paste

            Sheets(CSheet).Pictures(Pic.Index).Top = Pic.Top

            Sheets(CSheet).Pictures(Pic.Index).Left = Pic.Left

        Next Pic

        Sheets(CSheet).Activate

       

       'Reset the variable for the next sheet

        

Let 

BRow = 0

        

Let 

ECol = 0

    Next WSheet

   

     ' Since, Excel will automatically replace the sheet references for you on your formulas,

     ' the below part puts them back.

     ' This is done with a simple replace, replacing _Delete with nothing

    For Each WSheet In Worksheets

        WSheet.Activate

        Cells.Replace "_Delete", ""

    Next WSheet

   

    'Roll through the sheets and delete the original fat sheets

    For Each WSheet In Worksheets

        If Not Len(Replace(WSheet.Name, "_Delete", "")) = Len(WSheet.Name) Then

            

Let 

Application.DisplayAlerts = False

            WSheet.Delete

            

Let 

Application.DisplayAlerts = True

        End If

    Next

End Sub

Tags: VBA, Excel,, size, small, reduce, file, archive, tamanho, planilha, reduzir