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 ""
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