Страницы: 1 2 След.
RSS
Форматирование символов текста в зависимости от их цвета
 
Доброго времени суток!
Имеется текст в ячейках некоторые слова которого написаны красным цветом. Необходимо заменить шрифт написанный красным цветом на курсив не меняя цвет.
Таблица большая, более 5000 строк...
К примеру: "Иван Иванов (сын Ивана Ивановича)" нужно заменить на "Иван Иванов (сын Ивана Ивановича)"

Во вложении пример с макросом, но если текст начинается с красного шрифта то макрос не работает...

Подскажите как это можно осуществить?
 
Доброе время суток.
Вариант для выделенного диапазона.
Код
Public Sub AddItalicForRed()
    Dim sXml As String
    Dim pReg As Object
    sXml = Selection.Value(xlRangeValueXMLSpreadsheet)
    sXml = Application.Trim(Replace$(Replace$(Replace$(sXml, vbCrLf, " "), vbLf, " "), vbCr, " "))
    Set pReg = CreateObject("VBScript.RegExp")
    pReg.Global = True: pReg.IgnoreCase = True
    pReg.Pattern = "(<Font html:Color=""#FF0000"">[^<>]+</Font>)(?!</I>)"
    sXml = pReg.Replace(sXml, "<I>$1</I>")
    Selection.Value(xlRangeValueXMLSpreadsheet) = sXml
End Sub
 
Спасибо, Андрей!
Ваш макрос Андрей работает только на небольших объемах, до 1000 сток. При больших объемах вылетает ошибка:
Цитата
Run-time error '1004': Application-defined or object-defined error
Если текст в ячейке весь красный, макрос тоже не срабатывает...
Изменено: HuKoJIau4 - 16.02.2019 13:35:09
 
1. Правила форума, об отображаемом имени. Измените логин. Прыгающий регистр, кракзяблики... У Вас недостаточно букв, что Вы так издеваетесь над своим ником?
2. Название темы должно отражать задачу,. Сейчас - общие слова. Предложите новое. Модераторы заменят
3. О параллельном размещении темы следует сообщать. И там, и здесь.

Помощь приостановлена до исправления замечаний
 
Цитата
HuKoJIau4 написал:
Если текст в ячейке весь красный, макрос тоже не срабатывает
Обговаривайте такие моменты сразу.
 
Цитата
vikttur написал:
1. Правила форума, об отображаемом имени. Измените логин. Прыгающий регистр, кракзяблики... У Вас недостаточно букв, что Вы так издеваетесь над своим ником?
Нормальный читаемый ник HuKoJIau4 - Николаич. Ну раз запрещено... исправил.
Цитата
vikttur написал:
2. Название темы должно отражать задачу,. Сейчас - общие слова. Предложите новое. Модераторы заменят

В правилах написано: 2.1. Название темы должно отражать смысл проблемы, а не конкретную задачу.
Смысл проблемы: Форматирование текста в ячейке макросом. Можете исправлять...

Цитата
vikttur написал:
3. О параллельном размещении темы следует сообщать. И там, и здесь.
В правилах форума об этом не написано.
Цитата
Юрий М написал:
Обговаривайте такие моменты сразу.
ок
 
Сергей Николаевич,

4. Не рекомендуется

   4.1. Создавать одинаковые темы или сообщения в разных форумах (cross-posting). Публикуя один и тот же вопрос в разных форумах и на дружественных сайтах вы заставляете сразу нескольких людей параллельно думать над вашей задачей и обесцениваете усилия тех, кто даст ответ вторым-третьим и т.д.

а там п.5 запрещено
s - не предоставлять ссылки на другие ресурсы в том случае, если тема была создана Вами не только на форуме сайта "Мир MS Excel"
Участники допустившие любое из этих нарушений будут забанены на срок от одного часа до навсегда.
По вопросам из тем форума, личку не читаю.
 
Цитата
Сергей Николаевич написал:В правилах форума об этом не написано.
п.4.1, цитата выше.
Т.е., судя по Вашему ответу, Вам безразлично, сколько времени помогающих  будет потеряно бесполезно?

Кросс
 
Цитата
HuKoJIau4 написал:
работает только на небольших объемах, до 1000 сток
тогда нужно переделать макрос для обработки блоками менее 1000 ячеек.
Цитата
HuKoJIau4 написал:
Если текст в ячейке весь красный, макрос тоже не срабатывает...
не преставлено в примере. Если было бы там, то дал бы частичное решение, так как для этого случая решение тривиально и не раз было представлено на форуме, то есть для меня не  интересно.
Изменено: Андрей VG - 16.02.2019 15:31:47
 
Цитата
БМВ написал:
4. Не рекомендуется
Не запрещено.
Цитата
vikttur написал:
Вам безразлично, сколько времени помогающих  будет потеряно бесполезно
Я дам знать участникам, если задача решится. Все кто помогал - молодцы и их время потраченное на решение задачи будет потрачено не зря.
Задача до сих пор не решена, ничего плохого в кроссе не вижу...
Цитата
БМВ написал:
не предоставлять ссылки на другие ресурсы
Я не предоставлял ссылки на другие ресурсы.
 
ТаДааааа
По вопросам из тем форума, личку не читаю.
 
Задача решена благодаря _Boroda_ с МИР MS EXCEL
Код
Sub tt()
    Dim d As Range, d0 As Range
    Set d0 = Selection
    col_ = 255
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    On Error Resume Next
    For Each d In d0
        With d
            ld_ = Len(.Value)
            ReDim ar(1 To ld_)
            For i = 1 To ld_
                ar(i) = .Characters(Start:=i, Length:=1).Font.Color
            Next i
            .Font.Color = 1
            For i = 1 To ld_
                If ar(i) = col_ Then
                    With .Characters(Start:=i, Length:=1).Font
                        .FontStyle = "курсив"
                        .Color = col_
                    End With
                End If
            Next i
        End With
    Next d
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub
Всем спасибо!
 
Цитата
Сергей Николаевич написал:
Задача решена благодаря _Boroda_ с МИР MS EXCEL
Сообщите, если не трудно, сколько по времени обрабатывает 1000 ячеек.
 
Примерно 3-4 сек, но это наверное от мощности системы зависит?
 
Угадайте, почему у медведей .FontStyle = "курсив" может не работат? :-) . Yes, it's right, because of language and "Italic" is necessary.
По вопросам из тем форума, личку не читаю.
 
Андрей VG, я тоже думал, что долго будет, а потом смотрю - не, вроде довольно-таки приемлимо
На моей машине, которую собирали 6 лет назад, 10 000 ячеек обрабатывает 28 секунд. Для работы с форматами - вполне

С твоим макросом, конечно же, по скорости не сравнить, но видишь, ограничение. У меня, кстати, ругается не на 1000 ячеек, а почему-то на немногим больше 100. Все ячейки с текстом "Иван Иванов (сын Ивана Ивановича)". Причем ругается на плавающее количество ячеек - примерно от 106 до 120, на каждый запуск макроса пропускает разное количество
Скажи мне, кудесник, любимец ба’гов...
 
Меня другое смущает...
Файл взят из первого сообщения.
В А14 копировано значение из А15. Дополнил - закрасил последние два символа - "к)" - красным. Смотрите, что получилось. Вернее - не "что", а "как"?

Похоже на какой-то локальный глюк.
После обработки в ячейке такое

В строке формул - нормальный текст.

Сохранить, закрыть. Открываем - сообщение о востановлении данных. В ячейке:
Цитата
Аркадий Кибардин (с.Надеждино, священникАркадий Кибардин (с.Надеждино, священник)
Получится ли у кого воспроизвести?

И, кстати, почему код в модуле листа, а не в общем модуле?
 
Цитата
vikttur написал:
Меня другое смущает
Меня тоже смущает первый файл: активируем А1 и выполняем в Immediate строку:
?ubound(split(activecell)). Результат = 2. Но ожидалось 4.
В чём прикол?
 
Код
Sub ShowSymbols()
  Dim i As Long, s As String
  For i = 1 To Len(ActiveCell)
    s = Mid(ActiveCell, i, 1)
    Debug.Print i, s, Asc(s), AscW(s)
  Next i
End Sub
Владимир
 
У меня с первым символом очень похожая фигня в 2010 Excel. В 2013 все нормально. Это похоже мой первый вариант http://www.excelworld.ru/forum/2-40806-270434-16-1550238568 что-то попортил

А код в модуле листа - да просто мне так больше нравится писать (при отсутствии каких-либо предпочтений для местонахождения кода, конечно). Быстрее добраться до него - ПКМ на ярлык, исходный текст
Скажи мне, кудесник, любимец ба’гов...
 
То ли какая-то проблема с кодом, то ли Офис сюрпризит.

Создал новую книгу. Копировал код в общий модуль.
В А2 записал
Цитата
Переход через Рубикон
Если последние символы черные, обрабатывет, как и писал автор.
Два последних символа красные - такой же сбой, как и в сообщении №17. После повторного открытия книги удаляется нечитаемое содержимое
Цитата
Восстановленные записи: Строковые свойства из части /xl/sharedStrings.xml (Строки)
В ячейке:
Цитата
Переход через РубикоПереход через Рубикон
Если закрасить предварительно 3, 4 правых символа, картина с форматированием меняется
Непонятный калейдоскоп.

Excel-2010
 
Эй, кто-нибудь прочитал #18? ))
 

Модифицированный код Александра и вроде без указанных недостатков.

Код
Sub tt()
    Dim d As Range, d0 As Range
    Dim ST As Integer, L As Integer
    Set d0 = Selection
    col_ = 255
    Application.ScreenUpdating = 0
    Application.Calculation = 3
    On Error Resume Next
    For Each d In d0
        With d
            For i = 1 To Len(.Value)
                If .Characters(Start:=i, Length:=1).Font.Color = col_ Then
                    If ST = 0 Then
                        ST = i
                        L = 0
                    End If
                    L = L + 1
                Else
                    If ST <> 0 Then
                        With .Characters(Start:=ST, Length:=L).Font
                            .Italic = True
                        End With
                        ST = 0
                    End If
                End If
            Next i
            If ST <> 0 Then
                With .Characters(Start:=ST, Length:=L).Font
                    .Italic = True
                End With
                ST = 0
            End If
        End With
    Next d
    Application.Calculation = 1
    Application.ScreenUpdating = 1
End Sub

Изменено: БМВ - 16.02.2019 18:35:13
По вопросам из тем форума, личку не читаю.
 
Цитата
Юрий М написал:
Эй, кто-нибудь прочитал #18? ))
#19. Chr(160) между некоторыми словами.
Изменено: sokol92 - 16.02.2019 18:50:55
Владимир
 
#21. Да, похоже на ошибку Excel (все версии), возникающую при форматировании отдельных символов ячеейки.
Владимир
 
Цитата
sokol92 написал:
Chr(160) между некоторыми словами
Это самое настоящее вредительство :)
 
Цитата
sokol92 написал:  похоже на ошибку Excel (все версии)
Спасибо, Владимир. Надо взять на заметку. Давно не заимался задачами с изменением форматов текста, а раньше не замечал такого... Пригодится.
 
Цитата
Chr(160)
Off. Наверняка, от Нимфов (туды их...) Word
Владимир
 
Цитата
vikttur написал:
Спасибо, Владимир.
Это Вам спасибо, я раньше такого тоже не замечал.

Похоже, следующий макрос, примененный к ячейке 12 34 56
сводит с ума любую версию Excel 2007-2016 (в т.ч. англоязычные):
Код
Sub test()
  Dim i As Long
  For i = 1 To Len(ActiveCell) - 1
    With ActiveCell.Characters(Start:=i, Length:=1).Font
      If .Color = vbRed Then
        .Italic = True
      End If
    End With
  Next i
End Sub

Старина Excel 2003, кажется, этой болезни не подвержен.
Изменено: sokol92 - 16.02.2019 20:04:38
Владимир
 
Как вариант, перенести в Word, сделать замену с форматом, перенести обратно.
Страницы: 1 2 След.
Наверх