Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Изменить шрифт цифр в смешанном тексте - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить шрифт цифр в смешанном тексте (Макросы/Sub)
Изменить шрифт цифр в смешанном тексте
Xpert Дата: Четверг, 18.01.2024, 08:47 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 115
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте.

Есть таблица, в ячейках которой могут содержаться только цифры, или и цифры и текст.

Написал макрос, который должен менять шрифт всех цифр, попадающихся в ячейках.

Макрос работает, но...на большом количестве ячеек ощутимо тормозит.

Прошу помощи в оптимизации оного, если возможно, конечно.

Пример прилагается.
К сообщению приложен файл: primer1.xls (50.5 Kb)
 
Ответить
СообщениеЗдравствуйте.

Есть таблица, в ячейках которой могут содержаться только цифры, или и цифры и текст.

Написал макрос, который должен менять шрифт всех цифр, попадающихся в ячейках.

Макрос работает, но...на большом количестве ячеек ощутимо тормозит.

Прошу помощи в оптимизации оного, если возможно, конечно.

Пример прилагается.

Автор - Xpert
Дата добавления - 18.01.2024 в 08:47
jun Дата: Четверг, 18.01.2024, 17:04 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Добрый день!
Может и не самый быстрый вариант (на регулярных выражениях). У меня, на моем старом компьютере 5000 строк обрабатывает за 30-40 секунд.
Код:
[vba]
Код
Sub change_font()
Dim t ' переменная для счетчика времени
Dim arr As Variant, lr As Long, i As Long, app

t = Timer ' пременная для определения времени работы макроса (запоминаем текущее время)

app = Application.Calculation

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Worksheets("Лист1") ' имя Лист1 поменять на нужное имя листа с исходной таблицей (для форматирования)
    lr = .Cells(.Rows.Count, 3).End(xlUp).Row ' определяем последнюю заполненную ячейку на листа в 3 столбце
    arr = .Range("C1:C" & lr) ' помещаем весь диапазон 3 столбца в массив
    For i = LBound(arr, 1) To UBound(arr, 1) ' цикл по строкам массива
        Call font_regex(.Name, arr(i, 1), i, 3) ' вызываем процедуру форматирования текста
    Next i
End With

Application.ScreenUpdating = True
Application.Calculation = app

Debug.Print "total: " & Timer - t ' выводим общее время выполения макроса
End Sub
Private Sub font_regex(shName As String, what, cnt As Long, col As Long)
' font_regex -- процедура красит цифры жирным шрифтом
' shName: имя листа ( в Вашем случае Лист1)
' what: ячейка для проверки ( в Вашем случае arr(i, 1))
' cnt: номер строки (в Вашем случае i)
' col: номер столбца ( в Вашем случае 3)
Dim i ' переменная , для цикла по совпадениям
    With CreateObject("VBScript.Regexp")
        .Global = True: .MultiLine = True: .Pattern = "\d+" ' используем глобальный и многострочный флаги
        If .test(what) Then ' если в ячейке содержатся цифры, то
            For Each i In .Execute(what) ' цикл по найденным совпадениям в ячейке
                ' i.firstindex + 1 ниже - это начальная позиция совпадения, а i.Length - длина совпавшего фрагмента
                Cells(cnt, col).Characters(i.firstindex + 1, i.Length).Font.Bold = True ' устанавливаем шрифт в жирный
            Next i
        End If
    End With
End Sub
[/vba]
К сообщению приложен файл: font_regex.xlsb (42.8 Kb)


Сообщение отредактировал jun - Пятница, 19.01.2024, 13:00
 
Ответить
СообщениеДобрый день!
Может и не самый быстрый вариант (на регулярных выражениях). У меня, на моем старом компьютере 5000 строк обрабатывает за 30-40 секунд.
Код:
[vba]
Код
Sub change_font()
Dim t ' переменная для счетчика времени
Dim arr As Variant, lr As Long, i As Long, app

t = Timer ' пременная для определения времени работы макроса (запоминаем текущее время)

app = Application.Calculation

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With Worksheets("Лист1") ' имя Лист1 поменять на нужное имя листа с исходной таблицей (для форматирования)
    lr = .Cells(.Rows.Count, 3).End(xlUp).Row ' определяем последнюю заполненную ячейку на листа в 3 столбце
    arr = .Range("C1:C" & lr) ' помещаем весь диапазон 3 столбца в массив
    For i = LBound(arr, 1) To UBound(arr, 1) ' цикл по строкам массива
        Call font_regex(.Name, arr(i, 1), i, 3) ' вызываем процедуру форматирования текста
    Next i
End With

Application.ScreenUpdating = True
Application.Calculation = app

Debug.Print "total: " & Timer - t ' выводим общее время выполения макроса
End Sub
Private Sub font_regex(shName As String, what, cnt As Long, col As Long)
' font_regex -- процедура красит цифры жирным шрифтом
' shName: имя листа ( в Вашем случае Лист1)
' what: ячейка для проверки ( в Вашем случае arr(i, 1))
' cnt: номер строки (в Вашем случае i)
' col: номер столбца ( в Вашем случае 3)
Dim i ' переменная , для цикла по совпадениям
    With CreateObject("VBScript.Regexp")
        .Global = True: .MultiLine = True: .Pattern = "\d+" ' используем глобальный и многострочный флаги
        If .test(what) Then ' если в ячейке содержатся цифры, то
            For Each i In .Execute(what) ' цикл по найденным совпадениям в ячейке
                ' i.firstindex + 1 ниже - это начальная позиция совпадения, а i.Length - длина совпавшего фрагмента
                Cells(cnt, col).Characters(i.firstindex + 1, i.Length).Font.Bold = True ' устанавливаем шрифт в жирный
            Next i
        End If
    End With
End Sub
[/vba]

Автор - jun
Дата добавления - 18.01.2024 в 17:04
Xpert Дата: Пятница, 19.01.2024, 10:02 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 115
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
jun, спасибо!
Буду пробовать Ваш вариант.
 
Ответить
Сообщениеjun, спасибо!
Буду пробовать Ваш вариант.

Автор - Xpert
Дата добавления - 19.01.2024 в 10:02
jun Дата: Пятница, 19.01.2024, 12:47 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 141
Репутация: 42 ±
Замечаний: 0% ±

Xpert, я отредактировал сообщение выше и обновил файл. Добавил комментарии в коде.
Также нашел ошибку, из за которой неправильно считалась длина символьной последовательности совпадения:
[vba]
Код
i.Length+1
[/vba]заменил на:
[vba]
Код
i.Length
[/vba]


Сообщение отредактировал jun - Пятница, 19.01.2024, 13:02
 
Ответить
СообщениеXpert, я отредактировал сообщение выше и обновил файл. Добавил комментарии в коде.
Также нашел ошибку, из за которой неправильно считалась длина символьной последовательности совпадения:
[vba]
Код
i.Length+1
[/vba]заменил на:
[vba]
Код
i.Length
[/vba]

Автор - jun
Дата добавления - 19.01.2024 в 12:47
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Изменить шрифт цифр в смешанном тексте (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!