Sub parsing()

Dim head As String          ' Строка заголовок
Dim pos_number As Integer   '
Dim len_head_end As Integer ' Длина строки заголовка
Dim f_number As Integer     ' Номер поля
Dim record_count As Long    ' Количество строк, которое нужно распарсить

Dim w1 As Worksheet
Dim w2 As Worksheet
Dim w3 As Worksheet


' Добавим пару листов
myWorksheetName = "Парсинг строк"
Sheets.Add.Name = myWorksheetName
Sheets(myWorksheetName).Move After:=Sheets(Sheets.Count)

myWorksheetName = "Поля и их длина"
Sheets.Add.Name = myWorksheetName
Sheets(myWorksheetName).Move After:=Sheets(Sheets.Count)

Set w1 = Sheets( 1 )
Set w2 = Sheets( 2 )
Set w3 = Sheets( 3 )

'Необходимые данные
head = w1.Cells( 1 ,  1 ).Value
len_head_end = InStrRev(head, ">")
record_count = w1.UsedRange.Row -  1  + w1.UsedRange.Rows.Count

mid_begin =  1 
mid_end =  0 
f_number =  0 
pos_number =  0 

'Цикл по заголовку
For i =  1  To len_head_end
  
  pos_number = InStr(i, head, ">")
  f_number = f_number +  1 
  
  mid_end = pos_number - mid_begin
  
  If i <= len_head_end Then
      
      ' Цикл позаписям
      For j =  1  To record_count
        w2.Cells(j, f_number).Value = Replace(Trim(Mid(w1.Cells(j,  1 ).Value, mid_begin, mid_end)), "<", "")
      Next j

      w3.Cells(f_number,  1 ).Value = Replace(Trim(Mid(head, mid_begin, mid_end)), "<", "")
      w3.Cells(f_number,  2 ).Value = mid_end
    
  End If
    
    i = pos_number +  1 
    mid_begin = i
Next i



End Sub