VBA code to find last rows and calculate multiple subtotals in the same column

I am trying to write VBA code to automate a monthly report. The below problem is one small part in a much larger macro automating many processes in the report. I need to find the subtotal for every sub program (SUB_PGM in column B). The values that need to be summed are in column H. It is important to note that there will not always be a consistent number of programs or transactions within the programs so sum ranges will never be consistent. My current VBA code works around this issue by referencing a lookup table containing the subtotaled values for the programs instead of trying to sum the rows in the desired set of data. For reference, the "Do Until ActiveCell = "'" " is because there is a ' underneath the last row with data in it. This is due to some other formatting reasons but I was using it as a stopping point in the loop.

While my current macro does successfully run and create these subtotals, it comes with the following error after running "Run-time error '1004': Application-defined or object-defined error. The debugger highlights the "If IsEmpty(ActiveCell.Offset(1)) Then". This error then prevents the next macro from running and the active cell after running becomes the last possible row in an excel file (1048576).

Below you will find my current code as well as a screenshot of the desired outcome. Thank you for your help!

Range("H4").Select
Selection.End(xlDown).Offset(1).Select
ActiveCell.FormulaR1C1 = _
    "=IFERROR(VLOOKUP('Current Subpgm'!R[-1]C[-6],Table3,2,FALSE), "" "")"

Do Until ActiveCell = "'"  

Selection.End(xlDown).Select

If IsEmpty(ActiveCell.Offset(1)) Then
ActiveCell.Offset(1).Select
ActiveCell.FormulaR1C1 = _
    "=IFERROR(VLOOKUP('Current Subpgm'!R[-1]C[-6],Table3,2,FALSE), "" "")"
Else
Selection.End(xlDown).Offset(1).Select
ActiveCell.FormulaR1C1 = _
    "=IFERROR(VLOOKUP('Current Subpgm'!R[-1]C[-6],Table3,2,FALSE), "" "")"
End If

Loop

Screenshot of desired outcome

While you can do this using code, are you aware that you can easily do this without code by simply inserting a Pivot Table? And a Pivot Table provides several other benefits...

The advice from cybernetic.nomad is 100% correct, however, without seeing your source data it isn't possible to help re-write your code to avoid using select/active.

From the error you describe, the problem sounds like the ActiveCell has reached the last row of the Worksheet, then doing .Offset(1) means the code tries to access a row beyond that.

Without trying to fix any underlying issue (like why didn't the code find the cell with an apostrophe), the obvious 'fix' would be to add this immediately before the If IsEmpty(ActiveCell.Offset(1)) Then line:

If ActiveCell.Row = ActiveCell.Parent.Rows.Count Then
    Exit Do
End If

... this just causes the loop to be exited if the ActiveCell has reached the last row of the Worksheet ... depending on your data, this may fix your problem ... or may not?!