Option Explicit

Sub Main()
    Dim i As Long
    Dim j As Long
    Dim lngRow As Long
    Dim arrRows As Variant
    Dim arrFields() As String
    Dim arrCodes As Variant
    Dim objSheet As Worksheet
    
    Application.ScreenUpdating = False
    Set objSheet = Worksheets.Add(, Sheets( 1 ))
    With objSheet
        .Name = "Results"
        Sheets( 1 ).Cells.Copy .Cells
        ' Make lines from Alt+Enter symbol
        lngRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = lngRow To  2  Step - 1 
            arrRows = Split(.Cells(i, "B"), Chr( 10 ))
            If UBound(arrRows) >  0  Then
                .Cells(i +  1 , "B").Resize(UBound(arrRows)).EntireRow.Insert
                .Cells(i, "B").Resize(UBound(arrRows) +  1 ) = Application.Transpose(arrRows)
            End If
        Next i
        ' Make headers
        arrCodes = Array("[т]", "[м]", "[д]", "[е]", "[пр]")
        With .Range("C1:G1")
            .Value = arrCodes
            .Font.Bold = True
        End With
        ' Make fields
        ReDim arrFields(UBound(arrCodes)) As String
        lngRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        On Error Resume Next
        For i =  2  To lngRow
            ReDim arrFields(UBound(arrCodes)) As String
            For j =  0  To UBound(arrCodes)
                arrFields(j) = Trim(Replace(ExtractText(.Cells(i, "B"), "(\" & arrCodes(j) & ")[^\[]*"), arrCodes(j), ""))
            Next j
            With .Cells(i, "B")
                .Value = Mid(.Value,  1 , IIf(IsError(InStr(.Value, "[")), Len(.Value), InStr(.Value, "[") -  1 ))
            End With
            .Cells(i, "C").Resize(,  5 ) = arrFields
        Next i
        On Error GoTo  0 
        ' Fill 1st column's empty cells with duplicates
        With .Columns("A:A").SpecialCells(xlCellTypeBlanks)
            .Value = "=R[-1]C"
            .Value = .Value
        End With
        .Range("A:G").Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Function ExtractText(strTxt As String, strPattern As String)
    Dim RegExp As Object
    Set RegExp = CreateObject("vbscript.regexp")
    With RegExp
        .Pattern = strPattern
        .Global = True
        ExtractText = .Execute(strTxt)( 0 )
    End With
End Function