Macro Grand Totals appear too far below table

[rjarvis]

Hello,

I have a worksheet that has 3 macros to sort and subtotal the table using different columns. Below is 1 of 3 similar macros. The problem is that the grand totals move progressively down the worksheet each time I run a macro. I currently have 200 lines of data with subtotals but the grand total is now at row 1550. What can I do to reset the last row?

Thanks

Sub JobSubtotals()
'
' JobSubtotals Macro
' Sort and Subtotal by Job
'
' Keyboard Shortcut: Ctrl+s
'
Range("A1").Select
Selection.RemoveSubtotal
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
ActiveWorkbook.Worksheets("Backlog").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Backlog").Sort.SortFields.Add Key:=Range("A2:A214" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Backlog").Sort.SortFields.Add Key:=Range("C2:C214" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Backlog").Sort
.SetRange Range("A1:AL214")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(8, 9, 10, _
11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, _
37, 38), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(8, 9, 10, _
11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, _
37, 38), Replace:=False, PageBreaks:=False, SummaryBelowData:=True
Range("A1").Select
ActiveSheet.Outline.ShowLevels RowLevels:=3
Selection.SpecialCells(xlCellTypeVisible).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("A1").Select
ActiveSheet.Outline.ShowLevels RowLevels:=5
End Sub