Доброго времени суток! Имеется текст в ячейках некоторые слова которого написаны красным цветом. Необходимо заменить шрифт написанный красным цветом на курсив не меняя цвет. Таблица большая, более 5000 строк... К примеру: "Иван Иванов (сын Ивана Ивановича)" нужно заменить на "Иван Иванов (сын Ивана Ивановича)"
Подскажите как это можно осуществить?
Доброго времени суток! Имеется текст в ячейках некоторые слова которого написаны красным цветом. Необходимо заменить шрифт написанный красным цветом на курсив не меняя цвет. Таблица большая, более 5000 строк... К примеру: "Иван Иванов (сын Ивана Ивановича)" нужно заменить на "Иван Иванов (сын Ивана Ивановича)"
Убегаю уже, ладно, без файла положу Работает в предварительно выделенном диапазоне [vba]
Код
Sub tt() Dim d As Range, d0 As Range Set d0 = Selection col_ = 255 Application.ScreenUpdating = 0 Application.Calculation = 3 For Each d In d0 With d ld_ = Len(.Value) For i = 1 To ld_ With .Characters(Start:=i, Length:=1).Font If .Color = col_ Then .FontStyle = "курсив" End If End With Next i End With Next d Application.Calculation = 1 Application.ScreenUpdating = 1 End Sub
[/vba]
Убегаю уже, ладно, без файла положу Работает в предварительно выделенном диапазоне [vba]
Код
Sub tt() Dim d As Range, d0 As Range Set d0 = Selection col_ = 255 Application.ScreenUpdating = 0 Application.Calculation = 3 For Each d In d0 With d ld_ = Len(.Value) For i = 1 To ld_ With .Characters(Start:=i, Length:=1).Font If .Color = col_ Then .FontStyle = "курсив" End If End With Next i End With Next d Application.Calculation = 1 Application.ScreenUpdating = 1 End Sub
_Boroda_, Спасибо! В большинстве случаев форматирует нормально, но есть места где этот макрос не срабатывает должным образом, форматирует только 1 букву в слове. Пример во вложении.
_Boroda_, Спасибо! В большинстве случаев форматирует нормально, но есть места где этот макрос не срабатывает должным образом, форматирует только 1 букву в слове. Пример во вложении.HuKoJIau4
Переносите текст временно в ворд и там спокойно замените на курсив Ваш красный текст при помощи инструмента замены. Потом перенесете обратно. Там все клацанием кнопок можно делать. Встали в поле что ищем, в расширенном режиме есть кнопка формат, выбрали там цвет. Перешли в поле на что меняем, опять в формат и там выбрали курсив. Нажали заменить все.
Переносите текст временно в ворд и там спокойно замените на курсив Ваш красный текст при помощи инструмента замены. Потом перенесете обратно. Там все клацанием кнопок можно делать. Встали в поле что ищем, в расширенном режиме есть кнопка формат, выбрали там цвет. Перешли в поле на что меняем, опять в формат и там выбрали курсив. Нажали заменить все.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Суббота, 16.02.2019, 12:23
ну да, размножил Ваш пример на 10000 и при вставке в ворд есть проблема, но ведь мы то не простаки, знаем что из Excel можно сохранить в HTM, его загрузить в Word, все сделать, а после уже перенести опять в Excel. Короче, если задача разовая или редкая, вариант полностью рабочий.
ну да, размножил Ваш пример на 10000 и при вставке в ворд есть проблема, но ведь мы то не простаки, знаем что из Excel можно сохранить в HTM, его загрузить в Word, все сделать, а после уже перенести опять в Excel. Короче, если задача разовая или редкая, вариант полностью рабочий.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Суббота, 16.02.2019, 15:10
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
[/vba]
Вот так попробуйте [vba]
Код
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_, Единственный человек наверное который помогает делом... Спасибо большое, ща попробую. …а то создал дубль темы на других форумах, налетели девочки, разнылись
_Boroda_, Единственный человек наверное который помогает делом... Спасибо большое, ща попробую. …а то создал дубль темы на других форумах, налетели девочки, разнылись HuKoJIau4
а то создал дубль темы на других форумах, налетели девочки, разнылись
А вот так не нужно было писать 1. Это очень уважаемые люди с огромным багажом знаний, которые, между прочим так, если вы вдруг не заметили, хотели вам помочь 2. Все то, о чем писали там, написано абсолютно верно и по делу. А Вы нарушаете Правила этого форума, о чем на Планете Вам прямо и указали. Для справки - "Запрещено ... не предоставлять ссылки ..." - это то же самое, что "Необходимо предоставлять ссылки" 3. Как вы думаете, когда вы в следующий раз придете сюда или туда за помощью, что сделают "девочки"?
И да, я далеко не единственный помогающий делом. Что здесь, что там
а то создал дубль темы на других форумах, налетели девочки, разнылись
А вот так не нужно было писать 1. Это очень уважаемые люди с огромным багажом знаний, которые, между прочим так, если вы вдруг не заметили, хотели вам помочь 2. Все то, о чем писали там, написано абсолютно верно и по делу. А Вы нарушаете Правила этого форума, о чем на Планете Вам прямо и указали. Для справки - "Запрещено ... не предоставлять ссылки ..." - это то же самое, что "Необходимо предоставлять ссылки" 3. Как вы думаете, когда вы в следующий раз придете сюда или туда за помощью, что сделают "девочки"?
И да, я далеко не единственный помогающий делом. Что здесь, что там_Boroda_
У Вас неправильный Word, он неправильно виснет. Я показал, что проделал на 10000 строк, это заняло меньше минуты всех действий. Просто в следующий раз потребуется изменить условие, и потребуется другой макрос, а вместо этого просто нужно осваивать и применять прочие инструменты.
И заканчивайте пререкаться что тут, что там. "девочки" возрастные, "приложат" мало не покажется.
У Вас неправильный Word, он неправильно виснет. Я показал, что проделал на 10000 строк, это заняло меньше минуты всех действий. Просто в следующий раз потребуется изменить условие, и потребуется другой макрос, а вместо этого просто нужно осваивать и применять прочие инструменты.
И заканчивайте пререкаться что тут, что там. "девочки" возрастные, "приложат" мало не покажется.
Поздно, там уже доигрался. С малышом сцепился. bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Сообщение отредактировал bmv98rus - Суббота, 16.02.2019, 16:35