Excel file size is 23MB with only 9 data entires and a VBA script

Question

I have been playing around with excel for the past few days getting to grips with VBA. I am trying to create a simple stock sheet that uses VBA and splits my sales per month.

I have written some code that will autofilter the stock list and copies each sold month specific entry and pastes in the appropriately named sheet (named by month). My code is below.

Does anyone have any idea why before I run the script, the workbook is 54kb. Then once I have run the script and the 9 entries have been split to the appropriate month, the file size is now 23 Mb?

 Sub populate_months()

Dim Months As Collection
Dim Month As Variant
Dim itemcost As Long, turnover As Long, expenses As Long, profit As Long


'Create unique Months using GeoUniqueValues function
Set Months = GetUniqueValues(ThisWorkbook.Sheets("Stock").Range("I2:I999").Value)

For Each Month In Months
    'This is for the next version where It will only create sheets when there is data for them.
    'If WorksheetExists(Month) = False Then
        'Sheets.Add(After:=Sheets(Sheets.Count)).Name = Month

    'Sold Data
    ThisWorkbook.Sheets("Stock").Activate
    With ThisWorkbook.Sheets("Stock")
        .AutoFilterMode = False
        With .Range("A1", "J1000")
            .AutoFilter Field:=9, Criteria1:=Month, VisibleDropDown:=False
            .Range("A1", Range("C1").End(xlDown)).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Month).Range("A2")

        End With
    End With

    ActiveSheet.AutoFilterMode = False

    'Expenses Data
    ThisWorkbook.Sheets("Expenses").Activate
    With ThisWorkbook.Sheets("Expenses")
        .AutoFilterMode = False
        With .Range("A1", "D1000")
            .AutoFilter Field:=4, Criteria1:=Month, VisibleDropDown:=False
            .Range("A1", Range("C1").End(xlDown)).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Month).Range("D2")
        End With
    End With

    ActiveSheet.AutoFilterMode = False



    'Format the Month sheet
    ThisWorkbook.Sheets(Month).Activate

    itemcost = Application.Sum(ActiveSheet.Range("B3", ActiveSheet.Range("B3").End(xlDown)))
    turnover = Application.Sum(ActiveSheet.Range("C3", ActiveSheet.Range("C3").End(xlDown)))
    expenses = Application.Sum(ActiveSheet.Range("F3", ActiveSheet.Range("F3").End(xlDown)))

    profit = turnover - (itemcost + expenses)

    ActiveSheet.Range("I3").Value = "Turn over (£)"
    ActiveSheet.Range("J3").Value = turnover
    ActiveSheet.Range("I4").Value = "Profit (£)"
    ActiveSheet.Range("J4").Value = profit

    ActiveSheet.Cells.Select
    ActiveSheet.Cells.EntireColumn.AutoFit


Next Month

ThisWorkbook.Worksheets("Stock").Activate
ActiveSheet.AutoFilterMode = False

Answer 1

.Range("A1", Range("C1").End(xlDown)).SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets(Month).Range("A2")

This line is copying three columns and potentially every single row (over 1 million rows in the newest version) whether there's data or not. This will cause the file size to increase because Excel thinks you want to keep track of every one of those rows. You should adjust any of your .End(xlDown) usage because this could evaluate to the last row of the spreadsheet, not the last row of your data.

Answer 2

Michael Murphy's answer explains very well why this happens, and how to stop it happening in future. If you have not already read it, go read it. This post instead exists as a way to undo the issue if it has already happened, and reduce the filesize again.

The following Sub will identify the "True" UsedRange of the Sheet (i.e. ignoring the blank/junk cells) and then delete all of the other Rows and Columns. Then just save the workbook, and the size will shrink

Sub TidySheet(ws As Worksheet)
    Dim TrueUsedRange As Range, UsedCells As Range, UsedArea As Range

    'Find all the Valid cells
    Set UsedCells = ws.Cells(1, 1)
    On Error Resume Next
    If Not (ws.Cells.SpecialCells(xlCellTypeConstants) Is Nothing) Then Set UsedCells = Union(UsedCells, ws.Cells.SpecialCells(xlCellTypeConstants))
    If Not (ws.Cells.SpecialCells(xlCellTypeComments) Is Nothing) Then Set UsedCells = Union(UsedCells, ws.Cells.SpecialCells(xlCellTypeComments))
    If Not (ws.Cells.SpecialCells(xlCellTypeFormulas) Is Nothing) Then Set UsedCells = Union(UsedCells, ws.Cells.SpecialCells(xlCellTypeFormulas))
    On Error GoTo 0

    'Make it a contiguous Rectangle
    Set TrueUsedRange = ws.Cells(1, 1)
    For Each UsedArea In UsedCells.Areas
        Set TrueUsedRange = ws.Range(TrueUsedRange, UsedArea)
    Next UsedArea

    'Delete unused Columns
    If TrueUsedRange.Columns.Count < ws.Columns.Count Then ws.Range(ws.Cells(1, ws.Columns.Count), ws.Cells(1, TrueUsedRange.Columns.Count + 1)).EntireColumn.Delete
    'Delete unused Rows
    If TrueUsedRange.Rows.Count < ws.Rows.Count Then ws.Range(ws.Cells(ws.Rows.Count, 1), ws.Cells(TrueUsedRange.Rows.Count + 1, 1)).EntireRow.Delete
End Sub