Страницы: 1
RSS
Как убрать ударение макросом? VBA
 
Добрый день всем. Как следует из названия есть проблема с автоматическим удалением ударения на букву.

Вручную автозаменой все прекрасно заменяется (у́ меняется на у). Но макрорекодер записывает Replace What:="у?", Replacement:="у". И удаляется любая буква, идущая за буквой у. Помогите, пожалуйста, найти, как макросом заменять или удалять ударение.

Еще круче: помогите заменить ά на а.
 
Покажите файл.

А "ещё круче" просто:

Код
1
2
    Cells.Replace What:=ChrW(940), Replacement:="a", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
И в общем аналогично можно заменить и остальные символы.
Изменено: Hugo - 29.10.2014 12:32:03
 
Убрать все ударения вам поможет макрос из одной строки:
Код
1
2
3
Sub УбратьУдарения()
    Cells.Replace ChrW(769), ""
End Sub
Ударение, по сути, — то добавочный символ (после буквы) с кодом 769

За исключением символов типа ά
где ударение и буква - единое целое (здесь это не ударение, а другой диакритический знак)
 
Игорь, спасибо, не сталкивался. Теперь знаю как это ударение при нужде поставить  :)
 
charmap
F1 творит чудеса
 
Мне также понадобилось удалить из текста все ударения с кодом 301, и меня заинтересовала эта проблема.

Кажется, мне удалось отделить символ с ударением от первого символа, о чем пишет Антон.

Макрос написан для MS Word, но при необходимости желающие могут преобразовать его в Excel.

Предлагаю следующий макрос для удаления ударений по всему тексту. Он получился не очень элегантным (так как приходится перебирать все символы текста), но должен работать корректно.
Для больших текстов данный макрос может работать долго, и можно порекомендовать обрабатывать большие тексты по частям.
Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub RemovingAcuteAccents()
    Dim rng As Range
     
    ' Выделение всего текста
    Selection.WholeStory
     
    str1 = Selection
    For i = 1 To Len(str1) - 1
        ' Макрос просматривает все символы. Среди них могут быть символы Ударение с кодом 301 (ChrW(769))
        ' Символы Ударение удаляются
        Set rng = ActiveDocument.Range(Start:=i - 1, End:=i)
        ' Диапазон rng здесь содержит очередной символ текста, который преобразуется в выделение,
        ' для того чтобы этот символ можно было при необходимости удалить
        rng.Select
        ' Проверяем, является ли выделенный символ ударением,
        ' и если да, то удаляем этот символ
        If Selection = ChrW(769) Then
            Selection.Delete Unit:=wdCharacter, Count:=1
            ' Так как общее количество символов после удаления ударения меняется,
            ' приходится изменить и счетчик
            i = i - 1
        End If
         
        ' Так как некоторое количество символов мы удаляем,
        ' общее количество символов в файле также меняется,
        ' и это количество приходится пересчитывать
         
        ' Выделение всего текста
        Selection.WholeStory
 
        If i > Len(Selection) - 1 Then
            ' Завершение макроса
            ' Снятие выделения в конце макроса
            Selection.MoveRight Unit:=wdCharacter, Count:=1
            ' Выход из макроса
            Exit Sub
        End If
    Next
End Sub
 
Уважаемые коллеги!
Поскольку столкнулся с тем, что предыдущий макрос некорректно удаляет некоторые ударения, я предлагаю еще один макрос для удаления ударений.
Он менее элегантный, чем предыдущий, но работает надежнее.
Макрос написан для MS Word, но при необходимости желающие могут преобразовать его в Excel.
Поскольку макрос производит перебор всех символов, то для больших текстов он может работать долго.

Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub Udalit_Udarenia1()
     'перебор всех символов
     Dim Chr As Object
     For Each Chr In ActiveDocument.Characters
        With Chr
            'Всего гласных букв в русском языке насчитывается 10:
            'а, е, ё, и, о, у, ы, э, ю, я.
 
            Select Case Chr
                Case "а" & ChrW(769)
                    Chr = "а"
                Case "е" & ChrW(769)
                    Chr = "е"
                Case "ё" & ChrW(769)
                    Chr = "ё"
                Case "и" & ChrW(769)
                    Chr = "и"
                Case "о" & ChrW(769)
                    Chr = "о"
                Case "у" & ChrW(769)
                    Chr = "у"
                Case "ы" & ChrW(769)
                    Chr = "ы"
                Case "э" & ChrW(769)
                    Chr = "э"
                Case "ю" & ChrW(769)
                    Chr = "ю"
                Case "я" & ChrW(769)
                    Chr = "я"
                 
                Case "А" & ChrW(769)
                    Chr = "А"
                Case "Е" & ChrW(769)
                    Chr = "Е"
                Case "Ё" & ChrW(769)
                    Chr = "Ё"
                Case "И" & ChrW(769)
                    Chr = "И"
                Case "О" & ChrW(769)
                    Chr = "О"
                Case "У" & ChrW(769)
                    Chr = "У"
                Case "Ы" & ChrW(769)
                    Chr = "Ы"
                Case "Э" & ChrW(769)
                    Chr = "Э"
                Case "Ю" & ChrW(769)
                    Chr = "Ю"
                Case "Я" & ChrW(769)
                    Chr = "Я"
            End Select
            
        End With
     Next
End Sub

Прикладываю к этому сообщению файл Word для тестирования удаления ударений.
Изменено: Alex_Gur - 05.11.2023 22:39:01 (Редактирование и добавление тестового файла)
 
Макрос для быстрой установки ударения (для Word):
Код
1
2
3
4
5
6
7
Sub Udarenie1()
'
' установить курсор после буквы, над которой нужно поставить ударение
'
    Selection.TypeText Text:="301"
    Selection.ToggleCharacterCode
End Sub
 
Вот еще макрос, позволяющий удалить ударения из выделенного фрагмента в Ворде.
Этот макрос можно использовать также в случае, когда текст слишком большой. Можно будет выделать отдельные фрагменты текста и удалять ударения в этих фрагментах.
Код
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub Udalenie_Udarenij_In_Selection1()
'Удаление ударений из выделенного фрагмента
'Предварительно нужно выделить фрагмент, в котором будет выполняться удаление ударений
 
    Dim rng As Range
    Set rng = Selection.Range
 
     'перебор всех символов
     Dim Chr As Object
     For Each Chr In rng.Characters
        With Chr
            'Всего гласных букв в русском языке насчитывается 10:
            'а, е, ё, и, о, у, ы, э, ю, я.
 
            Select Case Chr
                Case "а" & ChrW(769)
                    Chr = "а"
                Case "е" & ChrW(769)
                    Chr = "е"
                Case "ё" & ChrW(769)
                    Chr = "ё"
                Case "и" & ChrW(769)
                    Chr = "и"
                Case "о" & ChrW(769)
                    Chr = "о"
                Case "у" & ChrW(769)
                    Chr = "у"
                Case "ы" & ChrW(769)
                    Chr = "ы"
                Case "э" & ChrW(769)
                    Chr = "э"
                Case "ю" & ChrW(769)
                    Chr = "ю"
                Case "я" & ChrW(769)
                    Chr = "я"
                 
                Case "А" & ChrW(769)
                    Chr = "А"
                Case "Е" & ChrW(769)
                    Chr = "Е"
                Case "Ё" & ChrW(769)
                    Chr = "Ё"
                Case "И" & ChrW(769)
                    Chr = "И"
                Case "О" & ChrW(769)
                    Chr = "О"
                Case "У" & ChrW(769)
                    Chr = "У"
                Case "Ы" & ChrW(769)
                    Chr = "Ы"
                Case "Э" & ChrW(769)
                    Chr = "Э"
                Case "Ю" & ChrW(769)
                    Chr = "Ю"
                Case "Я" & ChrW(769)
                    Chr = "Я"
            End Select
            
        End With
     Next
End Sub
Изменено: Alex_Gur - 06.11.2023 11:00:50
Страницы: 1
Читают тему
Наверх
Loading...