Insert row above totals and include row in formula range

I need to add a new row before a row with totals and include the new row in the formula range.

The code adds the row after the row with the totals.

Private Sub IncidentesFR_Open()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim rng As Range, f As Range, r As Range  
  Dim i As Long, j As Long, n As Long, m As Long, d As Long
  Dim newRow As ListRow
  Dim cell As String
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("Incidentes")
  Set sh2 = Sheets("Incidentes FR")
  
  n = sh1.ListObjects(1).ListColumns("Situation").Index
  
  Set r = sh1.Columns(n)
  Set f = r.Find("Out of the Rules2", , xlValues, xlWhole, , , False)
  If Not f Is Nothing Then
    cell = f.Address
    Do
      For j = 2 To sh2.Range("A" & Rows.Count).End(3).Row  '** I had put "B" in the range, but the correct one is "A"... but the problem continues
        If sh2.Range("A" & j).Value = "" Then
          Set newRow = sh2.ListObjects(1).ListRows.Add '*****  does the command to add the new row have to be indexed?
          sh1.Rows(f.Row).Copy sh2.Range("A" & j)
          Exit For
        End If
      Next
      Set f = r.FindNext(f)
    Loop While f.Address <> cell
  End If

  Application.ScreenUpdating = True
End Sub

How do I create a row in the correct position and change the formula range when the new row is added?

Append Rows from One Excel Table to Another

Private Sub IncidentesFR_Open()
  
    Const CRITERIA_STRING As String = "Out of the Rules2"
    Const SHOW_MESSAGE As Boolean = True
    
    Application.ScreenUpdating = False

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it's not, use 'ActiveWorkbook' instead.
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Incidentes")
    Dim slo As ListObject: Set slo = sws.ListObjects(1)
    Dim srg As Range: Set srg = slo.DataBodyRange.EntireColumn
    Dim scrg As Range:
    Set scrg = slo.ListColumns("Situation").DataBodyRange
    Dim scell As Range: Set scell = scrg.Find(CRITERIA_STRING, _
        scrg.Cells(scrg.Cells.Count), xlFormulas, xlWhole)
    
    Dim dRowsCount As Long
    If scell Is Nothing Then GoTo ProcExit
        
    Dim sFirstCellAddress As String: sFirstCellAddress = scell.Address
        
    Dim dws As Worksheet: Set dws = wb.Sheets("Incidentes FR")
    Dim dlo As ListObject: Set dlo = dws.ListObjects(1)
    
    Dim dtcell As Range:
    Set dtcell = dlo.TotalsRowRange.Cells(dlo.ListColumns("Opened").Index)
    Dim dFormula As String: dFormula = dtcell.Formula
    Dim dPos As Long: dPos = InStr(dFormula, "(") + 1
    Dim dAddress As String: dAddress = Mid(dFormula, dPos, Len(dFormula) - dPos)
    Dim dtrg As Range: Set dtrg = dws.Range(dAddress)
    
    Dim drrg As Range:
    
    With dlo
        If .ListRows.Count = 0 Then
            Set drrg = .HeaderRowRange
        Else
            With .DataBodyRange
                Set drrg = .Rows(.Rows.Count)
            End With
        End If
    End With
    
    Do
        dRowsCount = dRowsCount + 1
        dlo.ListRows.Add
        srg.Rows(scell.Row).Copy Destination:=drrg.Offset(dRowsCount)
        Set scell = scrg.FindNext(After:=scell)
    Loop While scell.Address <> sFirstCellAddress
    
    If dRowsCount > 0 Then
        dtcell.Formula = Replace(dFormula, dAddress, _
            dtrg.Resize(dtrg.Rows.Count + dRowsCount).Address(0, 0))
    End If

ProcExit:
    
    Application.ScreenUpdating = True
    
    If SHOW_MESSAGE Then
        If dRowsCount = 0 Then
            MsgBox "No rows containing """ & CRITERIA_STRING & """ found.", _
                vbExclamation
        Else
            MsgBox dRowsCount & " row" & IIf(dRowsCount = 1, "", "s") _
                & " containing """ & CRITERIA_STRING & """ copied.", _
                vbInformation
        End If
    End If
            
End Sub