How to sum multiple columns that change sizes?

Below is a macro that works to sum areas of a column when each column area is just 10 cells. However, the column areas are not always the same length each time needing to run the macro. Also this seems like a lot of code for this task.

So how would this be coded to work when section areas would continually change? Also how would you create a Grand Total from all the subTotals?

Sub Macro1()

' Sum each department in column F
    Range("F4").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    ActiveCell.Offset(2, 0).Select
    'Now I need to get a sum of all the departments above

' Sum each department in column I
    Range("I4").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    ActiveCell.Offset(2, 0).Select
    'Now I need to get a sum of all the departments above
    
End Sub