VBA: Почему мой макрос замедляется с увеличением количества листов?

Question

Как и предлагалось вчера, я делю свой вопрос на две части, хотя думаю, что они могут быть связаны:

У меня есть макрос Excel, который в основном работает, но он становится медленнее, когда добавляется больше листов макросом Он создает до нескольких сотен листов, и каждый лист представляет собой отдельный отчет, поэтому я должен сохранить все листы. В начале 10 листов занимают около 10 секунд, но на 70/80 листах время почти утроится. Это только из-за количества листов, или я могу ускорить это снова?

Код немного длиннее, поэтому я сократил его для решения проблемы и пометил его в коде:

Sub My_Issues()
    Dim ColumnLetter As String, item As String
    Dim cell As Range
    Dim sheetCount As Integer, TotalRow As Integer, TotalCol As Integer
    Dim uniqueArray As Variant
    Dim lastRow As Long, x As Long

    Application.ScreenUpdating = False

    'Get unique brands:
    With Sheets("Brand")
    .Columns(1).EntireColumn.Delete
    Sheets("Sales").Columns("R:R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    If .Range("A3:A" & lastRow).Cells.Count = 1 Then
    ReDim uniqueArray(1, 1)
    uniqueArray(1, 1) = .Range("A3")
    Else
    uniqueArray = .Range("A3:A" & lastRow).Value
    End If
    End With

    TotalRow = Sheets("Sales").UsedRange.Rows.Count
    TotalCol = Sheets("Sales").UsedRange.Columns.Count
    ColumnLetter = Split(Cells(1, TotalCol).Address, "$")(1) 'Num2Char
    sheetCount = 0 'Counter for statusbar

For x = 1 To UBound(uniqueArray, 1)
    item = uniqueArray(x, 1) 'item=Brand
    'Filter sales for each brand:
    With Sheets("Sales")
    .Range(.Cells(2, 1), .Cells(TotalRow, TotalCol)).AutoFilter Field:=18, Criteria1:=item
    End With

    With Sheets("Agents")
    'Delete old...
    .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown)).Clear
    '...and get new
    Sheets("Sales").Range(Sheets("Sales").Cells(3, 2), Sheets("Sales").Cells(2, 2).End(xlDown)).SpecialCells(xlCellTypeVisible).Copy
    .Range("A2").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    End With

    'List with all agents
    For Each cell In Worksheets("Agents").Range("A2", Worksheets("Agents").Range("A1").End(xlDown))

    With Sheets("Report")
    .Range("I4") = cell 'Copy agent and update the formulas within the report
'->Issue: It takes around 10 seconds to fill 10 sheets with the reports of 10 agents.
'When I reach 70-80 sheets, it slows down to 30 seconds for 10 sheets.
'Is this just because of the number of sheets, or can I speed it up again?

    .Range(.PageSetup.PrintArea).Copy
    Sheets.Add After:=Sheets("Report")

    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False

    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'Replace all formulas with values
    Application.CutCopyMode = False
    ActiveSheet.Name = cell

    sheetCount = sheetCount + 1
    If sheetAnz Mod 10 = 0 Then Application.StatusBar = sheetAnz 'Get statusupdate every 10 sheets
    End With
    Next

 Application.Wait (Now + TimeValue("0:00:01"))

    'Continue with other stuff.... sorting sheets and so on

Next

    Application.ScreenUpdating = True

End Sub

Есть идеи по этому вопросу?