✔ Programação GLOBAL®: DICA Excel - Tornando suas planilhas menores

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