Макрос конвертирование текста в html.

[drongo777]

Добрый день.
Имеется макрос, который конвертирует текст в html в определенном диапазоне ячеек. С одной ячейкой макрос работает, а если вставляешь текст сразу в несколько ячеек ошибка runtime error 424 object required.
В чем может быть ошибка?

Private Sub Worksheet_Change(ByVal Target As Range)
''' Контроль записи в ячейках и изменение при необходимости
''' Выполняется при изменении и вставке значений в диапазон ячеек
''' В данном случае для примера работает с диапазоном Range("A1:B10"
 
''' При желании диапазон можно подогнать под свои нужды типа UsedRange
''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 11)) /// и так далее


With ThisWorkbook
Dim sTmp As String, i As Long
Const TagA As String = "<p>"    ''' <p> - теги абзаца
Const TagP As String = "<br />" ''' <br /> - теги перевода строки
 
If Not Intersect(Target, Range("AD1:AD500")) Is Nothing Then
    ''' Загружаем значение в переменную с обрезанием лишних пробелов
     sTmp = Trim(Target.Value)
     ''' Досрочный выход если пусто
     If Len(sTmp) = 0 Then Exit Sub
     ''' Выполнение в тексте поиска переносов и замены на теги
     sTmp = Replace(sTmp, Chr(10), TagP, 1, -1, vbTextCompare)
     '''Дописуем в начале и в конце теги
    If Left(sTmp, 3) <> TagA And Right(sTmp, 3) <> TagA Then
        sTmp = TagA & sTmp & TagA
    ElseIf Left(sTmp, 3) = TagA And Right(sTmp, 3) <> TagA Then
        sTmp = sTmp & TagA
    ElseIf Left(sTmp, 3) <> TagA And Right(sTmp, 3) = TagA Then
        sTmp = TagA & sTmp
    End If
    ''' Возврат конвертированого текста обратно в ячейку
    Application.EnableEvents = False
      Target.Value = sTmp
    Application.EnableEvents = True
End If
End With

End Sub

_____
Код программы нужно выделять (форматировать) тегами [CODE] [/CODE] (читать FAQ)
Модератор

[Aleksandr H.]

1. пара для тега <p> разве не </p> или так и задумано ?
2.

Private Sub Worksheet_Change(ByVal Target As Range)
    ''' Контроль записи в ячейках и изменение при необходимости
    ''' Выполняется при изменении и вставке значений в диапазон ячеек
    ''' В данном случае для примера работает с диапазоном Range("AD1:B10"
    
    ''' При желании диапазон можно подогнать под свои нужды типа UsedRange
    ''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    ''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 11)) /// и так далее
    
    
    With ThisWorkbook
        Dim sTmp As String, i As Long, cl As Range
        Const TagA As String = "<p>"    ''' <p> - теги абзаца
        
        Const TagP As String = "<br />" ''' <br /> - теги перевода строки
        
        If Not Intersect(Target, Range("AD1:AD500")) Is Nothing Then
            ''' Загружаем значение в переменную с обрезанием лишних пробелов
            For Each cl In Target.Cells
                
                sTmp = Trim(cl)
                ''' следующая ячейка если пусто
                If Len(sTmp) <> 0 Then
                    ''' Выполнение в тексте поиска переносов и замены на теги
                    sTmp = Replace(sTmp, Chr(10), TagP, 1, -1, vbTextCompare)
                    '''Дописуем в начале и в конце теги
                    If Left(sTmp, 3) <> TagA And Right(sTmp, 3) <> TagA Then
                        sTmp = TagA & sTmp & TagA
                        ElseIf Left(sTmp, 3) = TagA And Right(sTmp, 3) <> TagA Then
                        sTmp = sTmp & TagA
                        ElseIf Left(sTmp, 3) <> TagA And Right(sTmp, 3) = TagA Then
                        sTmp = TagA & sTmp
                    End If
                    ''' Возврат конвертированого текста обратно в ячейку
                    Application.EnableEvents = False
                    cl = sTmp
                    Application.EnableEvents = True
                End If
            Next cl
        End If
    End With
    
End Sub

[drongo777]

Огромное спасибо. Теперь заработало при массовом заполнении. Но как Вы и указали без окончания </p>. Как изменить?

[drongo777]

Добавил с парой тегов <p></p>. Может кому пригодится.

Private Sub Worksheet_Change(ByVal Target As Range)
    ''' Контроль записи в ячейках и изменение при необходимости
    ''' Выполняется при изменении и вставке значений в диапазон ячеек
    ''' В данном случае для примера работает с диапазоном Range("AD1:B10"
    
    ''' При желании диапазон можно подогнать под свои нужды типа UsedRange
    ''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
    ''' или .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp).Offset(0, 11)) /// и так далее
    
    
    With ThisWorkbook
        Dim sTmp As String, i As Long, cl As Range
        Const TagA As String = "<p>"    ''' <p> - теги абзаца
        Const TagB As String = "</p>"    ''' </p> - теги абзаца
        Const TagP As String = "<br />" ''' <br /> - теги перевода строки
        
        If Not Intersect(Target, Range("AD1:AD500")) Is Nothing Then
            ''' Загружаем значение в переменную с обрезанием лишних пробелов
            For Each cl In Target.Cells
                
                sTmp = Trim(cl)
                ''' следующая ячейка если пусто
                If Len(sTmp) <> 0 Then
                    ''' Выполнение в тексте поиска переносов и замены на теги
                    sTmp = Replace(sTmp, Chr(10), TagP, 1, -1, vbTextCompare)
                    '''Дописуем в начале и в конце теги
                    If Left(sTmp, 3) <> TagA And Right(sTmp, 3) <> TagB Then
                        sTmp = TagA & sTmp & TagB
                        ElseIf Left(sTmp, 3) = TagA And Right(sTmp, 3) <> TagB Then
                        sTmp = sTmp & TagB
                        ElseIf Left(sTmp, 3) <> TagA And Right(sTmp, 3) = TagB Then
                        sTmp = TagA & sTmp
                    End If
                    ''' Возврат конвертированого текста обратно в ячейку
                    Application.EnableEvents = False
                    cl = sTmp
                    Application.EnableEvents = True
                End If
            Next cl
        End If
    End With
    
End Sub