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 "Обработка ядра завершена. Теперь можно посетить http://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