Sub TextOnRowsInRangeHARD()
 
'Автор: webley
'Редактор: JayBhagavan
'Адаптация под сложный перенос и коррекция: JeyCi
'Тема на сайте: http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=80210&TITLE_SEO=80210-razbit-tekst-v-yacheyke-po-strokam-cherez-proizvolnyy-razdelitel#postform
'=====================================================================================================================================================================================
  
Dim cl As Range, rng As Range, rngTmp As Range
Dim strDelim$, strTmp$
Dim Arr() As String
Dim i&, n&, j&, k&, a&

    strDelim = InputBox("Введите символ-разделитель")
    If strDelim = 10 Then strDelim = Chr(10) 'ввести "10" для использования в качестве разделителя "перенос строки"
    If strDelim = "" Then Exit Sub
      
Application.ScreenUpdating = False
       
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
    End If
      
    For i = rng.Rows.Count To 1 Step -1
    '***
        Max = 0
        For j = 1 To rng.Columns.Count
                strTmp = rng(i, j).Value & strDelim
                   Arr = Split(strTmp, strDelim)
                   a = UBound(Arr)
            Max = IIf(Max > a, Max, a)
        Next
        If Max <= 1 Then GoTo nx
    '***
        rng(i, 1).Offset(1, 0).Resize(Max - 1).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
   For j = 1 To rng.Columns.Count
            With rng(i, j)
            If InStr(rng(i, j), strDelim) Then
                strTmp = .Value '& strDelim
                Arr = Split(strTmp, strDelim)
                a = UBound(Arr)
                    Set rngTmp = .Resize(a)
                    For k = 0 To a
                        rngTmp(k + 1, 1).Value = Arr(k)
                    Next k
            End If
            End With
        Next j
nx:
    Next i
    
Application.ScreenUpdating = True

End Sub

strDelim = InputBox("Введите символ-разделитель")
If strDelim = 10 Then
   strDelim = Chr(10) 'ввести "10" для использования в качестве разделителя "перенос строки"
Else: Exit Sub
End If