excel 2007, макросы: Удалить строки в ячейке

[lapin9126]

Здравствуйте. Нужна помощь с макросом по удалению текста в ячейке. Если в ячейке более двух строк, то нужно оставить первые две (верхние).

Было:
Сусальным золотом горят
В лесах рождественские елки;
В кустах игрушечные волки
Глазами страшными глядят.

Надо:
Сусальным золотом горят
В лесах рождественские елки;

[вложение удалено администратором]

[Администратор]

Макрос

Sub Макрос()
   
    Dim shRes As Worksheet, arr()
    Dim spl, lr As Long, i As Long
   
   
    '1. Vba-именование листа, с которым надо работать.
    Set shRes = ActiveSheet

    '2. Проверка, что нет скрытых строк, чтобы не было непредвиденных ситуаций.
    If shRes.Columns("A").SpecialCells(xlCellTypeVisible).Rows.Count <> shRes.Columns("A").Rows.Count Then
        MsgBox "Отобразите скрытые строки.", vbExclamation
        Exit Sub
    End If
   
    '3. Копирование столбца B в массив, чтобы ускорить работу макроса: с массивом макрос быстрее работает.
    lr = shRes.Cells(shRes.Rows.Count, "B").End(xlUp).Row
    If lr = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = shRes.Range("B1").Value
    Else
        arr() = shRes.Range("B1:B" & lr).Value
    End If
   
    '4. Удаление текста после второго символа Chr(10) - он используется, чтобы переносить текст в ячейке
        ' на следующую строку.
    For i = 1 To UBound(arr, 1)
        ' Разбивка текста в ячейке на три части по символу Chr(10).
        spl = Split(arr(i, 1), Chr(10), 3)
        ' Если есть три части.
            ' У массива после Spit порядковый номер первого элемента ноль.
        If UBound(spl) = 2 Then
            ' Оставление только первых двух элементов.
            arr(i, 1) = spl(0) & Chr(10) & spl(1)
        End If
    Next i
   
    '5. Вставка изменённых данных обратно в эксель.
    shRes.Range("B1:B" & UBound(arr, 1)).Value = arr()
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[lapin9126]

Огромная благодарность. Всегда завидую умным людям.