✔ VBA Dashboards Specialist®: Excel Tips - Torne suas planilhas menores

31 de agosto de 2013

Excel Tips - Torne suas planilhas menores - SHRINK REDUCE EXCEL FILE SIZE

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

O que é o fenômeno chamado BIG DATA?

Acesse uma ENORME lista de Dashboards e Infográficos

Aprenda a detectar gráficos que precisam mudar

Dados ou Informações?

Dashboards - 8 Importantes características desejáveis

Dashboards e Infocharts - Diversas Visualizações de Dados

Diversos exemplos de Gráficos

Excel - DashMap - Mapa do Brasil

Key Performance Indicators - 7 Características desejáveis

MIS - Usufruindo a excelência na análise das suas Informações

O Melhor do Business Intelligence

Os 10 mandamentos do gerenciamento de projetos

Receba 3 Calendários Customizáveis de 2013 em Excel

Usando Gauges em Dashboards no MS Access

Já aconteceu de ter uma planilha de uns 5 ou 6 MB, na qual efetua algumas atualizações, talvez criando alguns gráficos, e algumas tabelas dinâmicas, de de repente 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