Sub ПРОПНАЧ()
    Selection.FormulaR1C1 = "=PROPER(RC[-1])"
End Sub
Sub ПРОПИСН()
 Selection.FormulaR1C1 = "=UPPER(RC[-1])"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

  If Not Intersect(Range("A9:A10000"), Target) Is Nothing Then

    del_space ' - тут все нормально, этот код никак не воздействует

  End If


If Not Intersect(Target, Columns(1)) Is Nothing Then
    Dim arrA(), I&, J&, splitA
    On Error Resume Next
    arrA = Range("A9:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For I = 1 To UBound(arrA)
            splitA = Split(arrA(I, 1))
            For J = 0 To UBound(splitA)
                If Not IsEmpty(splitA(J)) Then
                    iTemp = .Item(splitA(J))
                End If
            Next
        Next
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Range("B9:C9").Resize(UBound(.Keys) + 1) = Application.Transpose(.Keys)
    End With
    With Me.Sort
        .SortFields.Add Key:=Range("B:C"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Apply
    End With
End If


Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub Categorize
   Dim Cursor As Object, Map As Object, Range As Object
   Dim NumColumns As long, Col As long, NumRows As long
   Dim Head As String
   
   Map = ThisComponent.Sheets.getByName("Карта")
   Cursor = Map.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumColumns = Cursor.Columns.Count
   
   For Col = 0 To NumColumns - 1 Step 2
      Head = Map.getCellByPosition(Col, 0).String
      If Head <> "" Then
         NumRows = LastRowWithData(Col) + 1
         ParseMap(Head, Col, NumRows)
      End If
   Next Col
   MsgBox "Готово! Теперь можно посетить https://devaka.ru/ :)"
End Sub

Sub ParseMap (ByVal Head as String, ByVal Col as long, ByVal NumMarks as long)
   Dim Names(1 To NumMarks) As String, Keys(1 To NumMarks) As String
   Dim Core As Object, Map As Object, Cell As Object, Source As Object, Cursor As Object
   Dim I, J, NumRows, CellIndex
   
   CellIndex = GetCellByName(Head)
   Core = ThisComponent.Sheets.getByName("Ядро")
   Map = ThisComponent.Sheets.getByName("Карта")
   
   For I = 1 To NumMarks
      Keys(I) = Map.getCellByPosition(Col, I-1).String
      Names(I) = Map.getCellByPosition(Col + 1, I-1).String
   Next I
   
   Cursor = Core.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumRows = Cursor.Rows.Count
      
   For I = 1 To NumRows
      Source = Core.getCellByPosition(0, I)
      Cell = Core.getCellByPosition(CellIndex, I)
      
      For J = 1 To NumMarks
         If InStr(LCase(Source.String), LCase(Keys(J))) > 0 Then
            Cell.String = Names(J)
         End If
      Next J
   Next I
End Sub

Function GetCellByName (Head as String)
   Dim Core As Object, Cursor As Object
   Dim J
   
   Core = ThisComponent.Sheets.getByName("Ядро")
   Cursor = Core.createCursor
   Cursor.gotoEndOfUsedArea(True)
   NumColumns = Cursor.Columns.Count
   
   For J = 1 To NumColumns
      If Core.getCellByPosition(J - 1, 0).String = Head Then
         GetCellByName = J - 1
         Exit Function
      End If
   Next
   
   Core.Columns.insertByIndex(1, 1)
   Core.getCellByPosition(1, 0).String = Head
   GetCellByName = 1
End Function

Function LastRowWithData (ColumnIndex as long) as long
   Dim Cursor As Object, Range As Object, Map As Object
   Dim LastRowOfUsedArea as long, R as long
   Dim RangeData

   Map = ThisComponent.Sheets.getByName("Карта")
   Cursor = Map.createCursor
   Cursor.gotoEndOfUsedArea(False)
   LastRowOfUsedArea = Cursor.RangeAddress.EndRow
   Range = Map.getCellRangeByPosition(ColumnIndex, 0, ColumnIndex, LastRowOfUsedArea)
   Cursor = Map.createCursorByRange(Range)
   RangeData = Cursor.getDataArray

   For R = UBound(RangeData) To LBound(RangeData) Step - 1
      If RangeData(R)(0) <> "" then
         LastRowWithData = R
         Exit Function
      End If
   Next
End Function

Private Sub Worksheet_Change(ByVal Target As Range)

 If Not Intersect(Range("A1:B1000"), Target) Is Nothing Then Macros1
 
End Sub

Sub prot()
Dim LastRow As Long
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
With Range("G8:AC8")

.AutoFill Destination:=Range("G8:AC8" & .End(xlUp).Row)
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo err
  If Not Intersect(Target, Columns(1)) Is Nothing Then
  If IsEmpty(Range("A5:A10")) Then
End
Else
    Dim arrA(), I&, J&, splitA
    On Error Resume Next
    arrA = Range("A5:A" & Cells(Rows.Count, "A").End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For I = 1 To UBound(arrA)
            splitA = Split(arrA(I, 1))
            For J = 0 To UBound(splitA)
                If Not IsEmpty(splitA(J)) Then
                    iTemp = .Item(splitA(J))
                End If
            Next
        Next

        Application.ScreenUpdating = False
Range("I5").Resize(UBound(.Keys) + 1) = Application.Transpose(.Keys)
    End With
    With Me.Sort
        .SortFields.Add Key:=Range("I:I"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Apply
    End With
End If
End If

Application.ScreenUpdating = True
err:
End Sub