Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

Вернуться   Форум программистов > Microsoft Office и VBA > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail


Донат для форума - использовать для поднятия настроения себе и модераторам

А ещё здесь можно купить рекламу за 15 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru

Ответ
 
Опции темы
Старый 15.08.2019, 19:18   #1
drongo777
Новичок
Джуниор
 
Регистрация: 14.08.2019
Сообщений: 14
Репутация: 10
По умолчанию Макрос конвертирование текста в html по команде.

Добрый день.
Имеется макрос, который конвертирует текст в 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

Последний раз редактировалось drongo777; 15.08.2019 в 22:53.
drongo777 вне форума   Ответить с цитированием
Старый 16.08.2019, 08:07   #2
Aleksandr H.
2 the Nation Glory
Профессионал
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Адрес: Wild West Ukraine
Сообщений: 2,662
Репутация: 1096
По умолчанию

Имя функции и target другой, selection например или столбец, зависит от ТЗ
__________________
Mailto: media.project@ukr.net
Aleksandr H. на форуме   Ответить с цитированием
Старый 16.08.2019, 11:05   #3
drongo777
Новичок
Джуниор
 
Регистрация: 14.08.2019
Сообщений: 14
Репутация: 10
По умолчанию

Поменял код. Макрос работает, но не совсем корректно, он должен конвертировать текст в выделенных ячейках в столбце 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

Последний раз редактировалось drongo777; 16.08.2019 в 18:55.
drongo777 вне форума   Ответить с цитированием
Старый 16.08.2019, 22:59   #4
Aleksandr H.
2 the Nation Glory
Профессионал
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Адрес: Wild West Ukraine
Сообщений: 2,662
Репутация: 1096
По умолчанию

Так зачем гоняете по АЕ столбце?
Код:
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
__________________
Mailto: media.project@ukr.net
Aleksandr H. на форуме   Ответить с цитированием
Старый 16.08.2019, 23:09   #5
drongo777
Новичок
Джуниор
 
Регистрация: 14.08.2019
Сообщений: 14
Репутация: 10
По умолчанию

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

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Макрос конвертирование текста в html. drongo777 Microsoft Office Excel 3 15.08.2019 15:55
Хочу присоединиться к команде разработчиков. HTML, CSS, PHP sologub Работа на постоянной основе - Вакансии 0 13.01.2015 14:20
Присвоить макрос команде в созданной вкладке gbolgov Microsoft Office Excel 5 10.04.2012 17:52
Конвертирование rtf в html и обратно jocry Помощь студентам 1 11.01.2009 16:39
Изменение текста по команде aesoem Общие вопросы Delphi 2 27.01.2008 11:26


13:40.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.