Dim p&, b, g
b = ActiveCell.Value - 2
     For p = 1 To b
     g = p * 2 - 1
     ActiveCell.Offset(, -4).End(xlUp).Offset(g).Activate
     ActiveCell.Offset(p, 3).Value = ActiveCell.Address
     Next p

    a = ActiveCell.Value
      
     With ActiveCell
         b = a - 2

Sub Str()
     Dim r&, n&
      
     Application.ScreenUpdating = False
     With ActiveCell
         r = .Value - 2
         If r <= 0 Then Exit Sub ' достаточно одной проверки
         .Offset(1).Resize(r).EntireRow.Insert
         With .Offset(1, 1).Resize(r) ' присваиваем сразу всем (без цикла)
             .Font.Size = 16
             .Font.ThemeColor = 5
             .Value = "Переможець бою №"
         End With
         .Offset(, -4).Resize(r + 1, 14).Borders.LineStyle = 1 ' не понял зачем вам это, но оставил, чтобы не нарушать вашу логику
         n = 1 ' начальное смещение по строкам, относительно шапки таблицы
         For r = 1 To r
             .Offset(r, 3).Formula = "=" & Cells(4, 3).Offset(n).Address
             'MsgBox "Адрес об'единённого диапазона : " & Cells(4, 3).Offset(n).MergeArea.Address
             n = n + Cells(4, 3).Offset(n).MergeArea.Rows.Count ' смещение на следующую объединенную ячейку
         Next
     End With
     Application.ScreenUpdating = True
End Sub