Sub tekst()
  Dim St$, ps&, i&, ns&, n&, sz&, iL$, sh As Worksheet 'Объявляем переменные
  For Each sh In ThisWorkbook.Worksheets 'цикл перебора всех листов книги
    If Mid(sh.Name, 1, 1) <> "С" Then 'не пропускаем листы с именами на букву "С"
      iL = sh.Name  ' определяем имя листа
      With Sheets(iL) 'работаем с этим листом
        ps = .Range("C" & Rows.Count).End(xlUp).Row 'последяя заполненая строка в колонке С
        For i = 4 To ps ' цикл проверки колонки с 4-й по последнюю ячейку
          If .Cells(i, "C") <> "" Then 'Если ячейка колонки С не пустая
             St = .Cells(i, "C") 'Берем текст в переменную
             ns = InStr(St, " ") 'Ищем первый пробел в тексте
             If ns > 1 Then     ' если № пробела в тексте > 1
                 St = Mid(St, 1, ns - 1) 'выделяем 1-е слово из текста = "??????"
             End If
             St = "С" & St 'букву "С" соединяем со словом из текста = "С??????"
             sz = Sheets(St).Range("C" & Rows.Count).End(xlUp).Row + 1 ' последняя строка на листе "С??????"
             Range(.Cells(i, 1), .Cells(i, 7)).Copy Sheets(St).Cells(sz, 1) 'копируем строку на лист "С??????"
          End If
        Next
      End With
    End If
  Next
End Sub