Public Лист As String
   Public Строка As Long, Итого(1 To 3) As Long

Sub Разнос()

   Dim Шапка As Range
   Dim i As Long
   
   Лист = "qwe"
   With Worksheets(1)
      Set Шапка = .Range(.Cells(14, 2), .Cells(14, 16))
      For i = 15 To .Cells(Rows.Count, 6).End(xlUp).Row
         If InStr(1, .Cells(i, 4).Value, Лист, vbTextCompare) = 1 And .Cells(i, 4).Value <> "" Then
            .Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(Строка)
            Строка = Строка + 1
            Else
               If .Cells(i, 4).Value <> "" Then
                  If Лист <> "qwe" Then Call Оформление
                  Лист = IIf(IsNumeric(.Cells(i, 4).Value), .Cells(i, 4).Value, Left(.Cells(i, 4).Value, Len(.Cells(i, 4).Value) - 1))
                  Worksheets.Add after:=Worksheets(Sheets.Count)
                  ActiveSheet.Name = Лист
                  Шапка.Copy Destination:=Cells(14, 2)
                  With Cells(14, 17)
                     .Value = "Кол-во( суммарно)"
                     .Orientation = 90
                     Cells(14, 16).Copy
                     .PasteSpecial Paste:=xlPasteFormats
                  End With
                  .Rows(i).Copy Destination:=Worksheets(Лист & "").Rows(15)
                  Строка = 16
                  Итого(1) = 0
                  Итого(2) = 0
                  Итого(3) = 0
                  Else
                     If .Cells(i, 2) = "Итого по обычному" Then
                        Итого(1) = Итого(1) + .Cells(i, 6).Value
                        Итого(2) = Итого(2) + .Cells(i, 7).Value
                        Итого(3) = Итого(3) + .Cells(i, 8).Value
                     End If
               End If
         End If
      Next i
      Call Оформление
   End With

End Sub

Sub Оформление()

   Dim j As Long

   With Worksheets(Лист & "")
      For j = 1 To 3
         .Cells(Строка, j + 5).Value = Итого(j)
         .Cells(Строка + 2, j + 5).Value = Итого(j)
      Next j
      .Cells(Строка, 2).Value = "Итого по обычному"
      .Cells(Строка + 2, 2).Value = "Всего"
      With Worksheets(1)
         .Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 2).Copy
      End With
      .Range(.Cells(Строка + 2, 2), .Cells(Строка + 2, 17)).PasteSpecial Paste:=xlPasteFormats
      With .Range(.Cells(14, 2), .Cells(Строка + 2, 17))
         .Borders(xlInsideVertical).Weight = xlThin
         .Borders(xlInsideHorizontal).Weight = xlThin
         .Borders(xlEdgeBottom).Weight = xlThin
         .Borders(xlEdgeRight).Weight = xlThin
      End With
      For j = 15 To Строка - 1
         .Cells(j, 2).Value = j - 14
      Next j
   End With

End Sub

Sub iNomer()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim FoundCell As Range
Dim FAdr As String
Dim FAdr_Row As Long
Dim EAdr_Row As Long
Dim n As Integer
With CreateObject("scripting.dictionary"): .comparemode = 1
    n = 15
    iLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    Range("S15:S" & Cells(Rows.Count, "S").End(xlUp).Row).ClearContents
  For i = 15 To iLastRow      'выделяем из столбца C уникальные трехзначные номера
    If Cells(i, "C") <> "" Then
      If Not .exists(Left(Cells(i, "C").Value, 3)) Then
        'если нет слова, то добавляем его в словарь и в столбец S
        .Add Left(Cells(i, "C").Value, 3), 1
        Cells(n, "S") = Left(Cells(i, "C").Value, 3)
        n = n + 1
      End If
    End If
  Next
End With
     iLastRow = Cells(Rows.Count, "S").End(xlUp).Row
  For i = 15 To iLastRow                     'цикл по уникальным номерам в S
    Set FoundCell = Columns(3).Find(Cells(i, "S"), , xlValues, xlPart)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      FAdr_Row = FoundCell.Row               'первая строка с уникальным номером
      Do
        EAdr_Row = FoundCell.Row             'последняя строка с уникальным номером
        Set FoundCell = Columns(3).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
     With Worksheets(CStr(Cells(i, "S")))
       'очищаем диапазон на соответствующем листе
       .Range("B15:N" & .Cells(.Rows.Count, "B").End(xlUp).Row + 1).Clear
       'копируем диапазон от первой до последней строки + 2 уникального номера
       Range("B" & FAdr_Row & ":N" & EAdr_Row + 2).Copy .Range("B15")
       iLR = .Cells(.Rows.Count, "B").End(xlUp).Row
       .Range("B" & iLR + 1) = "Всего"
       .Range("D" & iLR + 1) = Application.Sum(.Range("D15:D" & iLR))
       .Range("E" & iLR + 1) = Application.Sum(.Range("E15:E" & iLR))
       .Range("F" & iLR + 1) = Application.Sum(.Range("F15:F" & iLR))
       .Range("N" & iLR + 1) = Application.Sum(.Range("N15:N" & iLR))
       For n = iLR To 15 Step -1    'удаляем строки на соответствующем листе с Итого
         If .Cells(n, "B") Like "Итого*" Then
           .Rows(n).Delete
         End If
       Next
     End With
  Next
End Sub