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