Sub ПРОМЕЖУТОЧНЫЕ_ИТОГИ()
    Dim WS_Count As Integer, i As Integer, r As Range, rng As Range, lr As Long
    WS_Count = ActiveWorkbook.Worksheets.Count
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.IgnoreCase = True
    For i = 1 To WS_Count
        With ActiveWorkbook.Worksheets(i)
            lr = .Cells(Rows.Count, 3).End(xlUp).Row
            objRegExp.Pattern = "460-"
            For Each r In .Range("C1:C" & lr)
                If objRegExp.Test(r) Then If rng Is Nothing Then Set rng = .Rows(r.Row) Else Set rng = Union(rng, .Rows(r.Row))
            Next r
            If Not rng Is Nothing Then rng.Font.Size = 8
            .Range("B1:F" & lr).Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            Set rng = Nothing
            lr = .Cells(Rows.Count, 3).End(xlUp).Row
            objRegExp.Pattern = "итог"
            For Each r In .Range("C1:C" & lr)
                If objRegExp.Test(r) Then If rng Is Nothing Then Set rng = r Else Set rng = Union(rng, r)
            Next r
            If Not rng Is Nothing Then rng = "Итог": rng.Offset(1, 0).EntireRow.Insert
'''''''''''' закомментировать строку выше и раскомментировать ниже если нужно удалить "Итог" совсем
'            If Not rng Is Nothing Then rng.Clear: rng.Offset(1, 0).EntireRow.Insert
            Set rng = Nothing
        End With
    Next i
End Sub

Sub Test()
    Dim i As Long, LastRow As Long
    
    'цикл по всем листам в активной книге
    For i = 1 To ActiveWorkbook.Worksheets.Count
        'с очередным листом делаем (от 1 до кол-ва листов в файле)
        With ActiveWorkbook.Worksheets(i)
            'ищем последнюю заполненную строку в столбце F
            LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
            'проверяем, что в столбце С написано слово "Итог", тогда делаем ниже
            If .Cells(LastRow, "C") = "Итог" Then
                'делаем шрифт жирным
                .Cells(LastRow, "F").Font.Bold = True
                'выравниваем значение ячейки по горизонтали
                .Cells(LastRow, "F").HorizontalAlignment = xlCenter
            End If
        End With
    Next i
    MsgBox "Конец", vbInformation, ""
End Sub

Sub Test2()
    Dim i As Long, Rng As Range, firstAddress As String
    
    'цикл по всем листам в активной книге
    For i = 1 To ActiveWorkbook.Worksheets.Count
        'с очередным листом делаем (от 1 до кол-ва листов в файле)
        With ActiveWorkbook.Worksheets(i)
            'производим поиск слова "Итог" в столбце С (3-й столбец)
            Set Rng = .Columns(3).Find("Итог", , xlFormulas, xlWhole)
            'если где-то нашли слово "Итог", то
            If Not Rng Is Nothing Then
                'запоминаем адрес ячейки первого найденного слова "Итог"
                firstAddress = Rng.Address
                'начало цикла поиска
                Do
                    'делаем шрифт жирным в столбце F найденного значени Итог
                    .Cells(Rng.Row, "F").Font.Bold = True
                    'выравниваем значение ячейки по горизонтали
                    .Cells(Rng.Row, "F").HorizontalAlignment = xlCenter
                    'производим следующий поиск слова "Итог" в столбце С (3-й столбец)
                    Set Rng = .Columns(3).FindNext(Rng)
                    'производим цикл поиска по столбцу "С" пока поиск не приведёт нас к первой найденной ячейки Итог
                Loop Until Rng.Address = firstAddress
            End If
        End With
    Next i 'переходим к другому листу
    MsgBox "Конец", vbInformation, ""
End Sub