DICA Excel - Tornando suas planilhas menores - SHRINK REDUCE EXCEL FILE SIZE

Já aconteceu de você ter uma planilha de uns 5 ou 6 MB, a qual você efetuar algumas atualizações, talvez criando alguns gráficos, e algumas tabelas dinâmicas, vê essa planilha aumentar de tamanho de 3 a 100 vezes! Ficou surpreso? Sim porque é possível, então não se preocupe demais, vou ajudá-lo.

Bem, em primeiro lugar precisamos entender a diferença entre Excel Default Last Cell e Actual Last Cell. Quando pressionamos Ctrl + End para encontrar a última célula (Actual Last Cell), nós chegamos a Excel Default Last Cell, que pode ser a Actual Last Cell ou podem ser células vazias que ficam muito além desta. Quanto mais distante da Excel Default Last Cell estiver a Actual Last Cell mais espaço desnecessário está sendo ocupado na planilha atual.

Qual a solução? Apague todas as linhas e colunas além do Actual Last Cell em cada planilha. Se houver demasiadas planilhas e grandes conjuntos de dados, poderá usar o código VBA a seguir:

Option Explicit

Sub SHRINK_XL()

    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

        CSheet = WSheet.Name

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

        OSheet = CSheet & "_Delete"

        WSheet.Name = OSheet

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

        Sheets.Add

        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

                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

                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

        BRow = 0

        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

            Application.DisplayAlerts = False

            WSheet.Delete

            Application.DisplayAlerts = True

        End If

    Next

End Sub

Tags: Bernardes, MS, Microsoft, Office, VBA, Sheet, woksheet, shrink, diminuir, reduce, compact, size, file, planilha, arquivo

André Luiz Bernardes

A&A® - Work smart, not hard.

bernardess@gmail.com

Skype: inanyplace 

LinkedIn
Plaxo