Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Помогите, пожалуйста, с макросом для изменеия регистра цифр на subscript в неотформатированной химической формуле (к примеру, в С2Н5OH 
)
Чего бы хотелось:
1. Изменение регистра всех цифр ТОЛЬКО в выделенном фрагменте
2. Перевод в нижний регистр также запятых и точек между цифрами
Отредактировано sylvio (19.03.2010 16:23:12)
Вот такая процедура переводит все цифры в нижний индекс в выделенном фрагменте. Данный вариант предполагает, что индексы состоят только из одной цифры.
Для дальнейшего усовершенствования неплохо бы привести формулу посложнее.
Sub Subscripts()
Dim rngChar As Range
Dim i As Long, CharCount As Long
CharCount = Selection.Characters.Count
If CharCount = 0 Then Exit Sub
For i = 1 To CharCount
Set rngChar = Selection.Characters(i)
If IsNumeric(rngChar.Text) Then rngChar.Font.Subscript = True
Next
End Sub
лучше воспользоваться поиском и заменой:
Sub ToSubscript()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([0-9]@)"
.MatchWildcards = True
.Replacement.Font.Subscript = True
.Replacement.Text = "\1"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
End Subadev и viter.alex большое спасибо за быстрый ответ.
Со знаками разобрался добавив еще один цикл поиска и замены на точки и запятые.
Тут пришла идея, что было бы удобнее, если бы макрос исполнялся для той формулы, на которой стоит курсор, то есть без выделения.
Как так сделать?
PS Для примера формула Fe0.33Ni0.5AlCo2
Отредактировано sylvio (19.03.2010 23:24:00)
Можно сделать
Sub ToSubscript()
Dim Sel As Long
Sel = Selection.Start 'Запоминаем положение курсора
Selection.MoveEndUntil " " 'раздвигаем выделение до пробела справа
Selection.MoveStartUntil " ", wdBackward 'раздвигаем выделение до пробела слева
'Поиск и замена в выделении
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([0-9]@)"
.MatchWildcards = True
.Replacement.Font.Subscript = True
.Replacement.Text = "\1"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
.Text = "[.,]"
.Replacement.Text = ","
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
'Возвращаем курсор на место
ActiveDocument.Range(Sel, Sel).Select
End SubСпасибо большое! Это именно то, что я хотел.
Немного вот изменил, чтобы и точки с запятыми переходили в subscript.
Sub ToSubscript()
Dim Sel As Long
Sel = Selection.Start 'Запоминаем положение курсора
Selection.MoveEndUntil " " 'раздвигаем выделение до пробела справа
Selection.MoveStartUntil " ", wdBackward 'раздвигаем выделение до пробела слева
'Поиск и замена в выделении
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "([0-9]@)"
.MatchWildcards = True
.Replacement.Font.Subscript = True
.Replacement.Text = "\1"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
.Text = "([.,])"
.Replacement.Text = "\1"
.Wrap = wdFindStop
.Execute Replace:=wdReplaceAll
End With
'Возвращаем курсор на место
ActiveDocument.Range(Sel, Sel).Select
End Sub]
Тогда, хотя бы для симметрии, надо иметь макрос и для superscript'а. Что надо изменить?
Немного вот изменил, чтобы и точки с запятыми переходили в subscript.
можно проще:
.Text = "([0-9.,]@)"
Тогда, хотя бы для симметрии, надо иметь макрос и для superscript'а. Что надо изменить?
.Replacement.Font.Superscript = True
Спасибо, Денис!
У меня та же проблема, но я работаю в Excel 2003 и данный макрос не хочет выполнятся на этой версии. Нельзя ли переписать его для данного приложения?
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться