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

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

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


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

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

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

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

Последний раз редактировалось Serge_Bliznykov; 14.08.2019 в 11:58.
drongo777 вне форума   Ответить с цитированием
Старый 14.08.2019, 17:50   #2
Aleksandr H.
2 the Nation Glory
Профессионал
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Адрес: Wild West Ukraine
Сообщений: 2,660
Репутация: 1096
По умолчанию

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

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

Последний раз редактировалось drongo777; 15.08.2019 в 01:39.
drongo777 вне форума   Ответить с цитированием
Старый 15.08.2019, 15:55   #4
drongo777
Новичок
Джуниор
 
Регистрация: 14.08.2019
Сообщений: 14
Репутация: 10
По умолчанию

Добавил с парой тегов <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
drongo777 вне форума   Ответить с цитированием
Ответ

Опции темы

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

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

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

Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Макрос изменение текста Scrydz Microsoft Office Word 1 11.09.2014 13:21
Макрос для замены текста Georgetta Microsoft Office Word 8 05.08.2011 12:00
Макрос форматирования текста DJTreeno Microsoft Office Excel 3 04.07.2011 10:41
Макрос разбивки текста rubbi Microsoft Office Word 1 09.11.2010 00:40
Конвертирование rtf в html и обратно jocry Помощь студентам 1 11.01.2009 16:39


03:04.


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

Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru