Помогите пожалуйста разбить текст из строки по столбцам

[tata70]

Необходимо чтобы название характеристики перед двоеточием ушла в заголовок столбца,а сама характеристика осталась в строке

[Казанский]

пробуйте

Sub Tata70()
Dim v(), i&, s$(), d, x, cl As New Collection
  v = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Value '.Resize(, 100)
  ReDim w$(0 To UBound(v), 1 To 50)
  On Error GoTo 1
  For i = 1 To UBound(v)
    For Each x In Split(v(i, 1), ";")
      s = Split(x, ":")
      If UBound(s) Then
        d = Trim(s(0))
        w(i, cl(d)) = Trim$(s(1))
      End If
    Next
  Next
  Rows(1).Insert
  Range("B1").Resize(UBound(w) + 1, cl.Count).Value = w
  Exit Sub

1 If Err.Number = 5 Then 'Invalid procedure call or argument - новый эл-т коллекции
    cl.Add cl.Count + 1, d
    If cl.Count > UBound(w, 2) Then ReDim Preserve w(0 To UBound(w), 1 To UBound(w, 2) * 2)
    w(0, cl.Count) = d
  Resume
  Else
    MsgBox "Непредвиденная ошибка " & Err & " " & Err.Description, vbCritical
    Exit Sub
  End If
End Sub

[ПаВлА]

Option Explicit
Option Base 1
Sub MuxiKotlety()
Dim Head, i&, x&, y&, lstr&
Application.ScreenUpdating = False
Head = Array("Торговая марка", "Сертификат", "Страна", "Состав", "Индивидуальная упаковка", "Размер упаковки", _
"Размер", "Вес", "Материал", "Тематика конструктора", "Возраст", "Типоразмер батареек", _
"Количество батареек", "Вид", "Материал для аппликации")
lstr = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Head)
        .Item(Head(i)) = i
    Next
    ReDim t(1 To UBound(Head) * lstr, 1 To UBound(Head))
    On Error Resume Next
    For x = 1 To lstr
        For y = 1 To UBound(Split(Cells(x, 2), ":"))
            i = .Item(Split(Split(Cells(x, 2), "; ")(y - 1), ": ")(0))
            If i = 0 Then MsgBox "Введите заголовок - <<" & Split(Split(Cells(x, 2), "; ")(y - 1), ": ")(0) & ">>": Exit Sub
            t(x, i) = Split(Split(Cells(x, 2), ": ")(y), "; ")(0)
        Next
    Next
End With
Sheets(2).[A1:R1] = Head
Sheets(2).[A2].Resize(lstr, UBound(Head)) = t
Application.ScreenUpdating = True
End Sub