Sub TextOnRows()

'Автор: webley
'Редактор JayBhagavan
'Сайт: planetaexcel.ru (http://planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=64813&TITLE_SEO=64813-tekst-po-strokam-iz-yacheyki)

Dim cl As Range, rng As Range, rngTmp As Range
Dim strDelim$, strTmp$
Dim Arr() As String
Dim i&, n&, j&, k&
 
    strDelim = InputBox("Введите символ-разделитель")
    If strDelim = "перенос" Then strDelim = Chr(10)
    If strDelim = "" Then End
     
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        n = rng.Rows.Count
        For i = n To 1 Step -1
            With rng(i, 1)
                strTmp = .Value & strDelim
                Arr = Split(strTmp, strDelim)
                j = UBound(Arr, 1) - 1
                If j > 0 Then
                    .Offset(1).Resize(j).EntireRow.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
                    Set rngTmp = .Resize(j + 1)
                    For k = 0 To j
                        rngTmp(k + 1, 1).Value = Arr(k)
                    Next k
                End If
            End With
        Next i
    End If
End Sub