Formating range is causing phantom rows

[SakiSam]

I have a workbook with a lot of subroutines that I've authored. I am having an issue with one of my subs taking way too long.

For this investigation I used the Task Manager to track down the problem. When I start the sub(routine), Excel is using 100MB of memory, when it's finished Excel is using 400+MB of memory. Running each line of the sub I find that this explosion of memory usage is occurring with the code I have to un-bold the subtotals. I've re-written and reordered the commands several times and the issue is definitely with this line.


After this point phantom rows are entered from the last used row to the bottom of the worksheet. Please review and advise what I am missing.


For a little

Sub FormatChart()

'Everything
Dim Rng As Range
Set Rng = Sheets(nPage).Range(Cells(fstRow, fstcol).Address, Cells(Cells(fstRow, TagTypCol).End(xlDown).Row, lstcol).Address)
    Rng.NumberFormat = "_(* #,##0_);_(* (#,##0);_(* "" - ""??_);_(@_)": Rng.Font.Bold = False: Rng.Font.Name = "Arial": Rng.Font.Size = 11: Rng.HorizontalAlignment = xlGeneral
'everything with header

Application.DisplayAlerts = False
Set Rng = Sheets(nPage).Range(Cells(fstRow - 1, fstcol).Address, Cells(Cells(fstRow, TagTypCol).End(xlDown).Row, lstcol).Address)
    Rng.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, _
        17, 18, 19, 20, 21), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

ActiveSheet.Outline.ShowLevels RowLevels:=2

'Subtotals
Set Rng = Sheets(nPage).Range(Cells(fstRow, fstcol).Address, Cells(Cells(fstRow, TagTypCol).End(xlDown).Row, lstcol).Address).SpecialCells(xlCellTypeVisible)
    Rng.Borders(xlDiagonalDown).LineStyle = xlNone: Rng.Borders(xlDiagonalUp).LineStyle = xlNone
    Subtotal1 Rng, xlEdgeLeft
    Subtotal1 Rng, xlEdgeTop
    Subtotal1 Rng, xlEdgeBottom
    Subtotal1 Rng, xlEdgeRight
    Subtotal1 Rng, xlInsideHorizontal
    Subtotal1 Rng, xlInsideVertical
    With Rng.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -4.99893185216834E-02
        .PatternTintAndShade = 0
    End With

'Subtotaled Tag Type headers
Set Rng = Sheets(nPage).Range(Cells(fstRow - 1, fstcol).Address & ":" & Cells(Cells(fstRow, TagTypCol).End(xlDown).Row - 1, TagTypCol).Address & "," & _
                             Cells(Cells(fstRow, TagTypCol).End(xlDown).Row, fstcol).Address & ":" & Cells(Cells(fstRow, TagTypCol).End(xlDown).Row, TagTypCol).Address).SpecialCells(xlCellTypeVisible)
    Rng.HorizontalAlignment = xlCenter: Rng.Merge True
'Subtotaled Tag Type headers without Bottom Grand Total
Set Rng = Sheets(nPage).Range(Cells(fstRow - 1, fstcol).Address, Cells(Cells(fstRow, TagTypCol).End(xlDown).Row - 1, lstcol).Address).SpecialCells(xlCellTypeVisible)

    With Rng.Font
        .Bold = False  [B]''''<------issue point[/B]
        .Size = 12
        .Name = "Arial"
    End With
    Rng.Replace " Total", "", xlPart

'Bottom Grand Total
Set Rng = Sheets(nPage).Range(Cells(Cells(fstRow, 1).End(xlDown).Row, fstcol).Address, Cells(Cells(fstRow, 1).End(xlDown).Row, lstcol).Address)
'Set rng = Sheets(nPage).Range("A508:U508")
    Rng.Interior.TintAndShade = 0: Rng.Replace "Grand ", "", xlPart: Rng.Font.Bold = False: Rng.Font.Size = 14
    Subtotal2 Rng, xlEdgeLeft
    Subtotal2 Rng, xlEdgeTop
    Subtotal2 Rng, xlEdgeBottom
    Subtotal2 Rng, xlEdgeRight

'Everything's borders
Set Rng = Sheets(nPage).Range(Cells(fstRow, fstcol).Address, Cells(Cells(fstRow, fstcol).End(xlDown).Row, lstcol).Address)
    Subtotal2 Rng, xlEdgeLeft
    Subtotal2 Rng, xlEdgeTop
    Subtotal2 Rng, xlEdgeRight

'TagType Column
Set Rng = Sheets(nPage).Range(Cells(fstRow, fstcol).Address, Cells(Cells(fstRow, fstcol).End(xlDown).Row, TagTypCol).Address)
    Subtotal2 Rng, xlEdgeRight
    Subtotal2 Rng, xlEdgeLeft

'Present Budgeted Total
Set Rng = Sheets(nPage).Range(Cells(fstRow, cntBcol).Address, Cells(Cells(fstRow, fstcol).End(xlDown).Row, cntBcol).Address)
    Subtotal2 Rng, xlEdgeRight
    Subtotal2 Rng, xlEdgeLeft
    Rng.Interior.TintAndShade = -4.99893185216834E-02

'Present Non-Budgeted Total
Set Rng = Sheets(nPage).Range(Cells(fstRow, 1 + cntBcol + cntNCol).Address, Cells(Cells(fstRow, fstcol).End(xlDown).Row, 1 + cntBcol + cntNCol).Address)
    Subtotal2 Rng, xlEdgeRight
    Subtotal2 Rng, xlEdgeLeft
    Rng.Interior.TintAndShade = -4.99893185216834E-02

'Present Month Total
Set Rng = Sheets(nPage).Range(Cells(Cells(fstRow, fstcol).End(xlDown).Row, lstcol).Address)
    Rng.Interior.TintAndShade = -0.149998474074526: Rng.Font.Size = 18
    Cells(6, 3).Value = "=" & Rng.Address(RowAbsolute:=False, ColumnAbsolute:=False)


Columns("D:E").Group: Columns("G:S").Group
Set Rng = Nothing


End Sub

Thank you