Размер файла Excel составляет 23 МБ, всего 9 данных и сценарий VBA

Question

Последние несколько дней я играл с Excel, чтобы разобраться с VBA.Я пытаюсь создать простой лист, который использует VBA и делит мои продажи в месяц.

Я написал некоторый код, который будет автофильтр список акций и копирует каждую проданную запись за конкретный месяц и вставляет в лист с соответствующим названием (названный по месяцам).Мой код приведен ниже.

Кто-нибудь знает, почему перед запуском скрипта рабочая книга составляет 54 КБ.Затем, когда я запустил скрипт и 9 записей были разделены на соответствующий месяц, размер файла теперь составляет 23 Мб?

 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")

Эта строка копирует три столбца и, возможно, каждую отдельную строку (более 1 миллиона строк в последней версии), независимо от того, есть данные или нет.Это приведет к увеличению размера файла, потому что Excel считает, что вы хотите отслеживать каждую из этих строк.Вам следует настроить любое использование .End(xlDown), так как это может привести к последней строке электронной таблицы, а не к последней строке ваших данных.

Answer 2

Ответ Майкла Мерфи очень хорошо объясняет, почему это происходит, и как остановить это в будущем.Если вы еще не прочитали его, прочитайте его. Эта запись вместо этого существует как способ отменить проблему, если она уже произошла, и снова уменьшить размер файла.

Следующая Sub идентифицирует "True "UsedRange листа" (т.е. игнорирование пустых / ненужных ячеек), а затем удалите все остальные строки и столбцы.Тогда просто сохраните книгу, и размер уменьшится

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