Доброго времени суток, уважаемые!
Воспаленное сознание родило следующий макрос, приводящий написание "м2" в более "красивый" вид (цифры приподняты). Макрос действует в выделенном диапазоне. Ищет в выделении значения "м2" "м3" (значения для поиска можно добавлять) и для цифр в этих строках изменяет шрифт на superscript.
Вопросы в следующем:
1. Может, кому пригодится?
2. Гуру-мастера - может посмотрите код - вдруг я велосипед изобрел?
Файл-пример прилагаю (код процедуры в единственном модуле проекта).
Текст процедуры:
Sub Надстрочный_символ_м2_м3()
'хочется, чтобы в текстовой строке, содержащейся в ячейке, все "м2" и "м3" заменялись на более "красивый вариант"
'с "приподнятым" шрифтом для цифр
Dim MyRange As Range 'переменная для объекта Selection
Dim MyCell As Range 'переменная для объекта Cell, которые будем перебирать в выделенном диапазоне
Dim intI As Integer 'переменная для определения номера позиции вхождений "м2" или "м3" в проверяемой строке
Dim strChecking As String 'переменная для хранения строки, которую будем курочить
Dim arrInNumber() As Integer 'массив неизвестной пока размерности для хранения значений позиций вхождения искомой строки
'в проверяемой
Dim arrInStr(2) As String 'массив, в который заносим строки, которые надо искать/заменять/изменять
Dim intJ As Integer 'переменная для определения размерности массива
Dim intK As Integer 'переменная для определения размерности массива arrInStr
'присваиваем элементам массива значения для поиска
arrInStr(1) = "м2"
arrInStr(2) = "м3"
Set MyRange = Selection 'устанавливаем переменной объект (выделенный диапазон)
'ПОГНАЛИ! Для каждой ячейки в выделенном фрагменте:
For Each MyCell In MyRange
MyCell.Activate 'как выяснилось, без активации ячейки никак - все действия по изменению шрифта происходят в активной
'ячейке
strChecking = CStr(MyCell.Value)
For intK = LBound(arrInStr()) To UBound(arrInStr())
intI = 1
intJ = 1
'проверяем, есть ли в строке элемент arrInStr() вообще, т.е. то, что надо поменять
If InStr(intI, strChecking, arrInStr(intK)) > 0 Then
'пока вхождение элемента массива arrInStr(), определенное для разных стартовых позиций поиска будет давать значение >0
'запускаем цикл, который находит номер позиции вхождения и присваивает его соответсвующему элементу массива arrInNumber()
Do
'изменяем размерность массива при увеличении количествва найденных вхождений
ReDim Preserve arrInNumber(intJ)
'присваиваем соотвествующему элементу массива номер найденного вхождения
arrInNumber(intJ) = InStr(intI, strChecking, arrInStr(intK))
'изменяем начальную позицию для поиска в строке вхождения
intI = InStr(intI, strChecking, arrInStr(intK)) + 1
'увеличиваем размерность массива arrInNumber()
intJ = intJ + 1
'условие проверяем в конце цикла, т.к. начальной проверкой через if мы уже убедились, что такое вхождение есть
'хотя бы в одном экземпляре
Loop While InStr(intI, strChecking, arrInStr(intK)) > 0
'для каждого найденного вхождения в строке (т.е. для всех элементов массива)
For intI = LBound(arrInNumber()) To UBound(arrInNumber())
'изменяем шрифт для цифр в "м2"
ActiveCell.Characters(Start:=arrInNumber(intI) + 1, Length:=1).Font.Superscript = True
Next intI
End If
Next intK
Next MyCell
Воспаленное сознание родило следующий макрос, приводящий написание "м2" в более "красивый" вид (цифры приподняты). Макрос действует в выделенном диапазоне. Ищет в выделении значения "м2" "м3" (значения для поиска можно добавлять) и для цифр в этих строках изменяет шрифт на superscript.
Вопросы в следующем:
1. Может, кому пригодится?
2. Гуру-мастера - может посмотрите код - вдруг я велосипед изобрел?
Файл-пример прилагаю (код процедуры в единственном модуле проекта).
Текст процедуры:
Sub Надстрочный_символ_м2_м3()
'хочется, чтобы в текстовой строке, содержащейся в ячейке, все "м2" и "м3" заменялись на более "красивый вариант"
'с "приподнятым" шрифтом для цифр
Dim MyRange As Range 'переменная для объекта Selection
Dim MyCell As Range 'переменная для объекта Cell, которые будем перебирать в выделенном диапазоне
Dim intI As Integer 'переменная для определения номера позиции вхождений "м2" или "м3" в проверяемой строке
Dim strChecking As String 'переменная для хранения строки, которую будем курочить
Dim arrInNumber() As Integer 'массив неизвестной пока размерности для хранения значений позиций вхождения искомой строки
'в проверяемой
Dim arrInStr(2) As String 'массив, в который заносим строки, которые надо искать/заменять/изменять
Dim intJ As Integer 'переменная для определения размерности массива
Dim intK As Integer 'переменная для определения размерности массива arrInStr
'присваиваем элементам массива значения для поиска
arrInStr(1) = "м2"
arrInStr(2) = "м3"
Set MyRange = Selection 'устанавливаем переменной объект (выделенный диапазон)
'ПОГНАЛИ! Для каждой ячейки в выделенном фрагменте:
For Each MyCell In MyRange
MyCell.Activate 'как выяснилось, без активации ячейки никак - все действия по изменению шрифта происходят в активной
'ячейке
strChecking = CStr(MyCell.Value)
For intK = LBound(arrInStr()) To UBound(arrInStr())
intI = 1
intJ = 1
'проверяем, есть ли в строке элемент arrInStr() вообще, т.е. то, что надо поменять
If InStr(intI, strChecking, arrInStr(intK)) > 0 Then
'пока вхождение элемента массива arrInStr(), определенное для разных стартовых позиций поиска будет давать значение >0
'запускаем цикл, который находит номер позиции вхождения и присваивает его соответсвующему элементу массива arrInNumber()
Do
'изменяем размерность массива при увеличении количествва найденных вхождений
ReDim Preserve arrInNumber(intJ)
'присваиваем соотвествующему элементу массива номер найденного вхождения
arrInNumber(intJ) = InStr(intI, strChecking, arrInStr(intK))
'изменяем начальную позицию для поиска в строке вхождения
intI = InStr(intI, strChecking, arrInStr(intK)) + 1
'увеличиваем размерность массива arrInNumber()
intJ = intJ + 1
'условие проверяем в конце цикла, т.к. начальной проверкой через if мы уже убедились, что такое вхождение есть
'хотя бы в одном экземпляре
Loop While InStr(intI, strChecking, arrInStr(intK)) > 0
'для каждого найденного вхождения в строке (т.е. для всех элементов массива)
For intI = LBound(arrInNumber()) To UBound(arrInNumber())
'изменяем шрифт для цифр в "м2"
ActiveCell.Characters(Start:=arrInNumber(intI) + 1, Length:=1).Font.Superscript = True
Next intI
End If
Next intK
Next MyCell
Кому решение нужно - тот пример и рисует.