Процент изменения массива VBA

Question

Хотя процентная разница работает, когда я запускаю ее построчно в режиме отладки, я испытываю ошибку времени выполнения 91 после вычисления 10 из возможных 44 отдельных листов. Прилагаются 2 снимка экрана для справки До & EndResult .

Я пытаюсь ускорить код и убедиться, что он работает без сбоев. Если я попытаюсь избавиться от функций активации и выбора, чтобы они работали быстрее, как я буду действовать дальше? Заранее спасибо за руководство. РЕДАКТИРОВАТЬ: диапазон не является динамическим c, так как каждый месяц будет автоматически вставляться новый столбец месяца с данными. Также я прикрепил этот код.

Sub PercentageCalc()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = False

For i = 1 To Sheets.Count

pos = Sheets(i).Index
Sheets(pos).Activate
With ActiveSheet

If Len(Sheets(i).Name) < 5 Then


dcol = Cells(1, Columns.Count).End(xlToLeft).Column

    Columns(dcol).Select

    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    Columns(dcol + 1).Select
    Selection.Copy

    Columns(dcol).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False


Cells.Find(What:="year", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Offset(2).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-2]/RC[-12])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))
ActiveCell.Offset(5).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-2]/RC[-12])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))


Cells.Find(What:="month", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Offset(2).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-3]/RC[-4])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, 
ActiveCell.End(xlDown))
ActiveCell.Offset(5).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-3]/RC[-4])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, 
ActiveCell.End(xlDown))

dcolvar = Cells(1, Columns.Count).End(xlToLeft).Column

    Cells.Find(What:="qtr", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate

If dcolvar Like "2" Or dcolvar Like "4" Or dcolvar Like "7" Or dcolvar Like "10" Then
    Cells.Find(What:="qtr", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Offset(2).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-5])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))
ActiveCell.Offset(5).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-5])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))

Else

If dcolvar Like "3" Or dcolvar Like "5" Or dcolvar Like "8" Or dcolvar Like "11" Then
Cells.Find(What:="qtr", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Offset(2).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-6])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))
ActiveCell.Offset(5).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-6])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))

Else

Cells.Find(What:="qtr", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
ActiveCell.Offset(2).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-7])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))
ActiveCell.Offset(5).Select
ActiveCell.FormulaR1C1 = "=IFERROR((RC[-4]/RC[-7])-1,0)"
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.End(xlDown))

              End If            

           End If

      End If

End If

End With

Next i

Exit Sub

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.StatusBar = True


End Sub