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

[drongo777]

Добрый день.
Имеется макрос, который конвертирует текст в html в определенном диапазоне ячеек при изменении ячеек. Мне нужно переделать, чтобы конвертация выполнялась по запуску макроса вручную. Что в коде нужно изменить?

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("AE1:AE500")) 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

[Aleksandr H.]

Имя функции и target другой, selection например или столбец, зависит от ТЗ

[drongo777]

Поменял код. Макрос работает, но не совсем корректно, он должен конвертировать текст в выделенных ячейках в столбце AD, он конвертирует в столбце AD, но не зависимо выделены ячейки или нет. В чем может быть проблема?

Sub ds()
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 Selection.Range("AD1:AD500") Is Nothing Then
            ''' Загружаем значение в переменную с обрезанием лишних пробелов
            For Each cl In Range("AE2:AE500")
                
                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, 4) <> TagB Then
                    sTmp = TagA & sTmp & TagB
                    ElseIf Left(sTmp, 3) = TagA And Right(sTmp, 4) <> TagB Then
                       sTmp = sTmp & TagB
                    ElseIf Left(sTmp, 3) <> TagA And Right(sTmp, 4) = 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

[Aleksandr H.]

Так зачем гоняете по АЕ столбце?

For Each cl In Range("AE2:AE500")

Sub ds()
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 Selection.Range("A1:A500") Is Nothing Then
            ''' Загружаем значение в переменную с обрезанием лишних пробелов
            For Each cl In Selection
                
                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, 4) <> TagB Then
                    sTmp = TagA & sTmp & TagB
                    ElseIf Left(sTmp, 3) = TagA And Right(sTmp, 4) <> TagB Then
                       sTmp = sTmp & TagB
                    ElseIf Left(sTmp, 3) <> TagA And Right(sTmp, 4) = 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

[drongo777]

Спасибо огромное! Как я с selection только не пробовал, а оказалось так просто: