Есть тема (в архиве) на данном фуруме, но в ней нет ответа нужного мне.
Суть проблемы: мне (и не только) часто требуется производить форматирование текста вот в таком формате (с частым чередованием верхнего и нижнего регистра):
Поискав в сети нашёл вариант изменения последнего символа на надстрочный:
Код
Sub Nadstr()
' Переводим последний символ в надстрочное положение
With ActiveCell.Characters(Start:=Len(Selection), Length:=1)
.Font.Superscript = True
End With
End Sub
но он мне не подходит - мне необходимо производить произвольное (в любом положении) форматирование текста. Примеры оформления текста - на картинке выше. Т.е. в идеале хотелось бы иметь как в Word - Ctrl + "+" - включение/выключение нижнего (подстрочного) регистра. Ctrl + Shift + "+" - включение/отключение верхнего (надстрочного) регистра. Впрочем и выделение текста + гор.клавиша (подвязанная на макрос) более чем подойдёт. А то ползать по Ctrl+1 утомляет ¯\_(ツ)_/¯
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
Да, придётся текст прописывать с указанием принадлежности регистра, но пока ничего лучше не нашёл...