Excel VBA чрезмерное использование памяти с If Not Intersect?

Question

Моя рабочая книга содержит лист с формулами около 50 столбцов х 50 строк. Сам файл имеет около 500 КБ, без условий. форматирование, я по возможности избегал изменчивых функций. Когда я открываю книгу, использование памяти Excel составляет около 180 МБ, но когда я изменяю значение ячейки, которое пересчитывает таблицу, оно увеличивается до 2,8 ГБ. Единственный код VBA, который у меня есть:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim varray As Variant
    Dim i As Long
    ost = Cells(Rows.Count, "M").End(xlUp).Row
    varray = Range("M1:M200").Value
    If Not Intersect(Target, Columns(13)) Is Nothing Then   'If Not Intersect(Target, Range("A1:A3")) Is Nothing Then -- only act on changes to cells A1 to A3
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        For i = UBound(varray, 1) To LBound(varray, 1) Step -1  'Go backwards
            If i < 4 Then
                Application.Calculation = xlCalculationAutomatic
                Application.ScreenUpdating = True
                Exit Sub
            End If
            If VBA.Len(varray(i, 1)) > 0 Then
                Range(Cells(4, "T"), Cells(4, "BD")).Copy Cells(i, "T")
            Else
                Range(Cells(i, "T"), Cells(i, "BD")).ClearContents
            End If
        Next
        Application.Calculation = xlCalculationAutomatic
        Application.ScreenUpdating = True
    End If

End Sub

Я подозреваю, что этот код не идеален и делает беспорядок в памяти. Можно ли оптимизировать его, чтобы уменьшить использование памяти?

Answer 1

Кажется, что-то вроде того, что вы ищете:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rChanged As Range

    Set rChanged = Intersect(Target, Me.Range("M4", Me.Cells(Me.Rows.Count, "M")))
    If Not rChanged Is Nothing Then
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Dim ChangedCell As Range
        Dim rDest As Range
        Dim rClear As Range
        For Each ChangedCell In rChanged.Cells
            If Len(ChangedCell.Value) > 0 Then
                Select Case (rDest Is Nothing)
                    Case True:  Set rDest = Me.Cells(ChangedCell.Row, "T")
                    Case Else:  Set rDest = Union(rDest, Me.Cells(ChangedCell.Row, "T"))
                End Select
            Else
                Select Case (rClear Is Nothing)
                    Case True:  Set rClear = Me.Cells(ChangedCell.Row, "T").Resize(, Me.Range("T:BD").Columns.Count)
                    Case Else:  Set rClear = Union(rClear, Me.Cells(ChangedCell.Row, "T").Resize(, Me.Range("T:BD").Columns.Count))
                End Select
            End If
        Next ChangedCell

        If Not rDest Is Nothing Then Me.Range("T4:BD4").Copy rDest
        If Not rClear Is Nothing Then rClear.ClearContents

        With Application
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If

End Sub