Страницы: 1
RSS
Как выделенную в сторке формул часть символов сделать надстрочной или подстрочной?
 
Есть тема (в архиве) на данном фуруме, но в ней нет ответа нужного мне.

Суть проблемы: мне (и не только) часто требуется производить форматирование текста вот в таком формате (с частым чередованием верхнего и нижнего регистра):



Поискав в сети нашёл вариант изменения последнего символа на надстрочный:
Код
Sub Nadstr()
' Переводим последний символ в надстрочное положение
With ActiveCell.Characters(Start:=Len(Selection), Length:=1)
.Font.Superscript = True
End With
End Sub
но он мне не подходит - мне необходимо производить произвольное (в любом положении) форматирование текста. Примеры оформления текста - на картинке выше.
Т.е. в идеале хотелось бы иметь как в Word - Ctrl + "+" -  включение/выключение нижнего (подстрочного) регистра. Ctrl + Shift + "+" - включение/отключение верхнего (надстрочного) регистра. Впрочем и выделение текста + гор.клавиша (подвязанная на макрос) более чем подойдёт. А то ползать по Ctrl+1 утомляет ¯\_(ツ)_/¯
Изменено: tutochkin - 10.08.2020 15:43:43
 
Цитата
tutochkin написал: произвольное (в любом положении) форматирование текста
Никак, только вручную.
 
Нашёл вот такой вариант:

Код
Sub Super_Sub()
'
' Keyboard Shortcut: Ctrl+Shift+D
'
' If the characters are surrounded by "<" & ">" then they will be subscripted
' If the characters are surrounded by "{" & "}" then they will be superscripted
'
Dim NumSub
Dim NumSuper
Dim SubL
Dim SubR
Dim SuperL
Dim SuperR
Dim CheckSub, CheckSuper as Boolean
Dim CounterSub, CounterSuper as Integer
Dim aCell, CurrSelection As Range

For Each c In Selection
c.Select

CheckSub = True
CounterSub = 0
CheckSuper = True
CounterSuper = 0
aCell = ActiveCell
'
NumSub = Len(aCell) - Len(Application.WorksheetFunction.Substitute(aCell, "<", ""))
    NumSuper = Len(aCell) - Len(Application.WorksheetFunction.Substitute(aCell, "{", ""))
'
If Len(aCell) = 0 Then Exit Sub
If IsError(Application.Find("<", ActiveCell, 1)) = False Then
Do
    Do While CounterSub <= 1000
        SubL = Application.Find("<", ActiveCell, 1)
        SubR = Application.Find(">", ActiveCell, 1)
        ActiveCell.Characters(SubL, 1).Delete
        ActiveCell.Characters(SubR - 1, 1).Delete
        ActiveCell.Characters(SubL, SubR - SubL - 1).Font.Subscript = True
        CounterSub = CounterSub + 1
        If CounterSub = NumSub Then
            CheckSub = False
        Exit Do
        End If
    Loop
Loop Until CheckSub = False
End If
'
'
If IsError(Application.Find("{", ActiveCell, 1)) = False Then
Do
    Do While CounterSuper <= 1000
        SuperL = Application.Find("{", ActiveCell, 1)
        SuperR = Application.Find("}", ActiveCell, 1)
        ActiveCell.Characters(SuperL, 1).Delete
        ActiveCell.Characters(SuperR - 1, 1).Delete
        ActiveCell.Characters(SuperL, SuperR - SuperL - 1).Font.Superscript = True
        CounterSuper = CounterSuper + 1
        If CounterSuper = NumSuper Then
            CheckSuper = False
            Exit Do
        End If
    Loop
Loop Until CheckSuper = False
End If
'
Next

End Sub

Да, придётся текст прописывать с указанием принадлежности регистра, но пока ничего лучше не нашёл...
Изменено: tutochkin - 10.08.2020 16:46:20
Страницы: 1
Наверх