работа с большим объемом данных

[Ckif]

большим я называю от 300000Rx50C
судя по информации из диспетчера задач происходит накопление памяти что приводит к постепенному торможению выполнения макроса
в связи с чем возникает вопрос а можно ли как то избежать этого накопления
и в целом можно ли что нить придумать для ускорения работы макроса

Sub Экстраполяция101()
'
' Экстраполяция101 Макрос
'

'
Application.ScreenUpdating = False

'ActiveWindow.DisplayHeadings = True
'ActiveWindow.DisplayGridlines = True
'ActiveSheet.Name = "Динамика"
Range("A1").Select
Dim myChart As Chart
Dim mySeries As Series
Set myChart = Sheets("Динамика").Shapes.AddChart. Chart
myChart.SetSourceData Source:=Range("'Динамика'!" + Range("D12:AT12").Address)
Set mySeries = myChart.SeriesCollection(1)
myChart.ChartType = xlLine
mySeries.Trendlines.Add(Type:=xlLin ear, DisplayEquation:=True).Select
mySeries.Name = "Временной Ряд"
'Set myChart = Nothing
'Range("D12").Select
'ActiveWindow.FreezePanes = True
'Range("D10").Select
'ActiveCell.FormulaR1C1 = "1"
'Range("E10").Select
'ActiveCell.FormulaR1C1 = "2"
'Range("D10:E10").Select
'Selection.AutoFill Destination:=Range("D10:AY10"), Type:=xlFillDefault
'Range("D10:AY10").Select
'Columns("AU:AU").Select
'Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Range("AU11").Select
'Selection.Interior.Pattern = xlNone
'ActiveCell.FormulaR1C1 = "Линейная"
'Range("AV11:AZ11").Select
'Selection.Merge
'ActiveCell.FormulaR1C1 = "Прогноз"
'Range("AU12").Select
Dim a As String
Dim b As String
Dim c As Integer
Dim i As Long, j As Long
a = Range("D12:AT12").Address
b = Range("AU12").Address
For i = 12 To Range("C12").End(xlDown).Row
c = 0
With Range(a)
For j = 1 To .Count
If Not .Cells(1, j) = Empty Then
c = c + 1
End If
Next
End With
If c > 1 Then

myChart.SetSourceData Source:=Range("'Динамика'!" + a)
With mySeries
.Name = "Временной Ряд"
.Values = "='Динамика'!" + a
.Trendlines(1).DataLabel.Select
End With
eq = Selection.Text

TLEqn = eq
'remove the 'y' from the start of the trend line equation
TLEqnMod = Right(TLEqn, Len(TLEqn) - 1)
'remove spaces from the string
TLEqnMod = Trim(TLEqnMod)
'find the position of =, x and + in the equation
TLXPos = InStr(1, TLEqnMod, "x", vbTextCompare)
TLEqualPos = InStr(1, TLEqnMod, "=", vbTextCompare)
TLMinusPos = InStr(TLXPos + 1, TLEqnMod, "-", vbTextCompare)
TLAddPos = InStr(TLXPos + 1, TLEqnMod, "+", vbTextCompare)

If TLXPos = 0 Then
TLCoeff = "0"
TLConst = Trim(Mid(TLEqnMod, TLEqualPos + 1, Len(TLEqnMod) - TLAddPos))
ElseIf TLXPos <> 0 And TLMinusPos = 0 Then
TLCoeff = Trim(Mid(TLEqnMod, TLEqualPos + 1, TLXPos - TLEqualPos - 1))
TLConst = Trim(Mid(TLEqnMod, TLAddPos + 1, Len(TLEqnMod) - TLAddPos))
ElseIf TLXPos <> 0 And TLMinusPos <> 0 Then
TLCoeff = Trim(Mid(TLEqnMod, TLEqualPos + 1, TLXPos - TLEqualPos - 1))
TLConst = Trim(Mid(TLEqnMod, TLMinusPos, Len(TLEqnMod) - TLMinusPos + 1))
End If

If Len(TLEqnMod) = TLXPos Then
TLConst = "0"
End If


Range(b).Value = eq

If TLCoeff = "-" Then
TLCoeff = "-1"
End If
If TLCoeff = "" Then
TLCoeff = "1"
End If

TLCoeff = CDbl(TLCoeff)
TLConst = CDbl(TLConst)

With Range(Range(b).Offset(0, 1).Address + ":" + Range(b).Offset(0, 5).Address)
For j = 1 To 5
If (TLCoeff * Cells(10, 47 + j) + TLConst) < 0 Then
.Cells(1, j) = ""
Else
.Cells(1, j) = TLCoeff * Cells(10, 47 + j) + TLConst
End If
Next
End With
End If

b = Range(b).Offset(1, 0).Address
a = Range(a).Offset(1, 0).Address
Application.StatusBar = "Экстраполирование. ВЫПОЛНЕНО: " & i * 100 / Range("C12").End(xlDown).Row & "%"
Next
Columns("AU:AU").EntireColumn.AutoF it
End Sub

[EducatedFool]

и в целом можно ли что нить придумать для ускорения работы макроса

1. Полностью отказаться от использования методов Select и Activate

2. В главном цикле убрать все обращения к ячейкам и диапазонам - сравняваться должны только значения из массивов
(при таких объёмах данных сначала считываем всё данные из диапазонов в массивы, потом обрабатываем массивы, и результат аналогично записываем на лист)
Смотрите пример использования здесь: http://excelvba.ru/code/DeleteBlankRows

3. Убираем загадочные конструкции типа этих: Range(Range(b).Offset(0, 1).Address + ":" + Range(b).Offset(0, 5).Address)
То же самое можно записать в таком виде:

Sub test()
    ' вместо этого
    Dim b As String
    b = Range("AU12").Address
    With Range(Range(b).Offset(0, 1).Address + ":" + Range(b).Offset(0, 5).Address)
        For j = 1 To 5
            If (TLCoeff * Cells(10, 47 + j) + TLConst) < 0 Then
                .Cells(1, j) = ""
            Else
                .Cells(1, j) = TLCoeff * Cells(10, 47 + j) + TLConst
            End If
        Next
    End With

    ' пишем как-то так:
    Dim bb As Range: Set bb = Range("AU12")
    With bb.Next.Resize(, 5)
        For j = 1 To 5
            If (TLCoeff * Cells(10, 47 + j) + TLConst) < 0 Then
                .Cells(j) = ""
            Else
                .Cells(j) = TLCoeff * Cells(10, 47 + j) + TLConst
            End If
        Next
    End With

    ' или лучше так:
    Dim bb As Range, n As Double: Set bb = Range("AU12")
    
    For j = 1 To 5
        n = TLCoeff * Cells(10, 47 + j) + TLConst
        bb.Offset(, j) = IIf(n < 0, "", n)
    Next
End Sub