Автор Тема: Word VBA Макросы: Как заменить слова, у которых больше 4 букв?  (Прочитано 973 раз)

Оффлайн 4340000

  • Посетитель форума
  • Сообщений: 6
Скажите, пожалуйста, как изменить этот макрос, чтобы он заменял только те слова, у которых больше 4 букв:?
Макрос
Sub Макрос()
Dim w As Range, i&, j&, s$
  Application.ScreenUpdating = False
  For i = ActiveDocument.Words.Count To 1 Step -1
    Set w = ActiveDocument.Words(i)
    If w.Text Like "[А-Яа-яA-Za-z]*" Then
      j = j + 1
      If j Mod 3 = 0 Then
        w.MoveEndWhile " ", wdBackward
        s = w.Text
        With w.Fields.Add(Range:=w, Type:=wdFieldEmpty)
          .Code.Text = "eq " & s
        End With
'        w.Fields.Update
      End If
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Оффлайн Администратор

  • Administrator
  • Сообщений: 1561
Макрос
Sub Макрос()

    Dim w As Range, text As String
    Dim counter As Long, i As Long
   
   
    '1. Отключение монитора. Может это ускорит макрос.
    Application.ScreenUpdating = False
   
    '2. Вставка поля в некоторые слова.
    ' Цикл по всем словам в файле (в основной части).
    For i = ActiveDocument.Words.Count To 1 Step -1
       
        '1) Присваиваем имя слову.
        Set w = ActiveDocument.Words(i)
       
        '2) Проверка, что слово начинается с буквы.
        If Not w.text Like "[А-Яа-яЁёA-Za-z]*" Then
            GoTo metka_NextWord
        End If
       
        '3) Убирание правого пробела из слова.
        w.MoveEndWhile " ", wdBackward
       
        '4) Копирование слова в переменную.
        text = w.text
       
        '5) Проверка, что в слове не менее 4-х символов.
        If Len(text) < 4 Then
            GoTo metka_NextWord
        End If
       
        '6) Подсчёт, сколько уже встретилось таких слов.
        counter = counter + 1
       
        '7) Интересует каждое третье слово.
        If counter Mod 3 <> 0 Then
            GoTo metka_NextWord
        End If
       
        '8) Удаление слова и вставка на его место поля.
        With w.Fields.Add(Range:=w, Type:=wdFieldEmpty)
            .Code.text = "eq " & text
        End With
           
metka_NextWord:
    Next i
   
    '3. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

Оффлайн 4340000

  • Посетитель форума
  • Сообщений: 6

Оффлайн monokl

  • Посетитель форума
  • Сообщений: 8
Здравствуйте, можно ли сделать в данном макросе так, чтобы при замене исключались слова со знаками препинания, или знаки препинания учитывались вместе со словом, а не стояли отдельно за скобкой, например так: {eq деятельность,}
Спасибо!

Оффлайн Администратор

  • Administrator
  • Сообщений: 1561
Этот макрос включает в поле знаки препинания.

Макрос
Sub макрос()
   
    Dim cursor As Range, chars As String
    ' Знак подчёркивания на конце, чтобы не совпадало с объектом Word.
        ' Иначе не понятно, как это всё состыкуется.
    Dim word_ As Range, text As String, counter As Long
   
   
    ' Символы, между которыми макрос обрабатывает текст.
    chars = " " & Chr(7) & Chr(12) & Chr(13)
   
    ' Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '1. Установка невидимого курсора в начало файла.
    Set cursor = ActiveDocument.Range(0, 0)
   
    '2. Смещение курсора до первого символа, не являющегося пробелом, разрывом и знаком абзаца.
    cursor.MoveWhile Cset:=chars, Count:=wdForward
   
    '3. Движение по файлу.
    Do
        '1) Выделение фрагмента от символа, который не является пробелом, разрывом и знаком абзаца, до
            ' пробела, разрыва или знака абзаца.
        cursor.MoveEndUntil Cset:=chars, Count:=wdForward
       
        '2) Присваивание имени "word_" найденному тексту.
            ' Duplicate - чтобы при изменении переменной "word_" не изменялась переменная "cursor".
        Set word_ = cursor.Duplicate
   
        '3) Смещение невидимого курсора вправо, чтобы установить невидимый курсор
            ' после найденного текста, чтобы продолжить движение от невидимого курсора до конца файла.
        cursor.Collapse Direction:=wdCollapseEnd
       
        '4) Проверка, что слово начинается с буквы.
        If Not word_.text Like "[А-Яа-яЁёA-Za-z]*" Then
            GoTo metka_NextWord
        End If
       
        '5) Копирование слова в переменную. С переменной макрос быстрее работает, чем с объектами.
        text = word_.text
       
        '6) Проверка, что в слове не менее 4-х символов. Если справа есть знак препинания,
            ' то он тоже подсчитывается.
        If Len(text) < 4 Then
            GoTo metka_NextWord
        End If
       
        '7) Подсчёт, сколько уже встретилось таких слов.
        counter = counter + 1
       
        '8) Интересует каждое третье слово.
        If counter Mod 3 <> 0 Then
            GoTo metka_NextWord
        End If
       
        '9) Удаление слова и вставка на его место поля.
        With word_.Fields.Add(Range:=word_, Type:=wdFieldEmpty)
            .Code.text = "eq " & text
        End With
       
        '10) Установка невидимого курсора справа от вставленного поля. После вставки поля,
            ' невидимый курсор устанавливается перед вставленнным полем.
        cursor.MoveUntil Cset:=chars, Count:=wdForward

metka_NextWord:

        '11) Смещение курсора вправо до первого символа, который не являетя пробелом,
            ' разрывом и знаком абзаца. Если будет возвращён 0, значит невидимый
            ' курсор не сдвинулся. Это означает, что достигнут конец файла.
        If cursor.MoveWhile(Cset:=chars, Count:=wdForward) = 0 Then
            Exit Do
        End If
       
    Loop
   
    '4. Сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation

End Sub

Оффлайн monokl

  • Посетитель форума
  • Сообщений: 8
Отлично! Большое спасибо!

Оффлайн monokl

  • Посетитель форума
  • Сообщений: 8
Вопрос по данному макросу.
При комбинации shift + f9, или alt + f9, слова преобразованные макросом выделяются, например, из изначального слова: появляется в {eq появляется}.

Нужно сделать так, чтобы при комбинации shift + f9, или alt + f9, слова не выделялись. Имеется пример, в котором это работает, выделений нет. Прикрепляю его. Если я правильно понял, то в макросе к части поля применен белый шрифт, с малым размером, масштабом и уплотнением.

[вложение удалено администратором]

Оффлайн Администратор

  • Administrator
  • Сообщений: 1561
В этот макрос добавлено уменьшение шрифта, как в вашем файле примере. Цвет шрифта не изменяется.

Макрос
Sub макрос()
   
    Dim cursor As Range, chars As String
    ' Знак подчёркивания на конце, чтобы не совпадало с объектом Word.
        ' Иначе не понятно, как это всё состыкуется.
    Dim word_ As Range, text As String, counter As Long
    Dim field As field, rng As Range
   
   
    ' Символы, между которыми макрос обрабатывает текст.
    chars = " " & Chr(7) & Chr(12) & Chr(13)
   
    ' Отключение монитора (может это ускорит макрос и не будет мерцать).
    Application.ScreenUpdating = False
   
    '1. Установка невидимого курсора в начало файла.
    Set cursor = ActiveDocument.Range(0, 0)
   
    '2. Смещение курсора до первого символа, не являющегося пробелом, разрывом и знаком абзаца.
    cursor.MoveWhile Cset:=chars, Count:=wdForward
   
    '3. Движение по файлу.
    Do
        '1) Выделение фрагмента от символа, который не является пробелом, разрывом и знаком абзаца, до
            ' пробела, разрыва или знака абзаца.
        cursor.MoveEndUntil Cset:=chars, Count:=wdForward
       
        '2) Присваивание имени "word_" найденному тексту.
            ' Duplicate - чтобы при изменении переменной "word_" не изменялась переменная "cursor".
        Set word_ = cursor.Duplicate
   
        '3) Смещение невидимого курсора вправо, чтобы установить невидимый курсор
            ' после найденного текста, чтобы продолжить движение от невидимого курсора до конца файла.
        cursor.Collapse Direction:=wdCollapseEnd
       
        '4) Проверка, что слово начинается с буквы.
        If Not word_.text Like "[А-Яа-яЁёA-Za-z]*" Then
            GoTo metka_NextWord
        End If
       
        '5) Копирование слова в переменную. С переменной макрос быстрее работает, чем с объектами.
        text = word_.text
       
        '6) Проверка, что в слове не менее 4-х символов. Если справа есть знак препинания,
            ' то он тоже подсчитывается.
        If Len(text) < 4 Then
            GoTo metka_NextWord
        End If
       
        '7) Подсчёт, сколько уже встретилось таких слов.
        counter = counter + 1
       
        '8) Интересует каждое третье слово.
        If counter Mod 3 <> 0 Then
            GoTo metka_NextWord
        End If
       
        '9) Работа с полем.
        'a) Удаление слова и вставка на его место поля. При этом полю присваиваем имя 'field',
            ' чтобы дальше в коде обращаться к полю по имени 'field'.
        Set field = word_.Fields.Add(Range:=word_, Type:=wdFieldEmpty)
        'b) Запись в поле кода.
        field.Code.text = "eq " & text
        'c) Уменьшение размеров некоторых элементов поля: скобок, кода и пробела после него.
        ' Присваиваем фрагменту файла, где находится поле, имя 'rng'.
        Set rng = field.Code.Duplicate
        ' Изменяем переменную 'rng': делаем так, чтобы включить в неё левую скобку.
        rng.Start = rng.Start - 1
        ' Включаем в 'rng' левую скобку, код 'eq' и пробел.
        rng.SetRange rng.Start, rng.Start + 4
        ' Уменьшаем шрифт.
        With rng.Font
            .Size = 1
            .Scaling = 1
            .Spacing = -100
        End With
        ' Действия для правой скобки.
        With field.Code.Characters.Last.Next.Font
            .Size = 1
            .Scaling = 1
            .Spacing = -100
        End With
       
        '10) Установка невидимого курсора справа от вставленного поля. После вставки поля,
            ' невидимый курсор устанавливается перед вставленнным полем.
        cursor.MoveUntil Cset:=chars, Count:=wdForward

metka_NextWord:

        '11) Смещение курсора вправо до первого символа, который не являетя пробелом,
            ' разрывом и знаком абзаца. Если будет возвращён 0, значит невидимый
            ' курсор не сдвинулся. Это означает, что достигнут конец файла.
        If cursor.MoveWhile(Cset:=chars, Count:=wdForward) = 0 Then
            Exit Do
        End If
       
    Loop
   
    '4. Сообщение.
    Application.ScreenUpdating = True
    MsgBox "Готово.", vbInformation

End Sub

Оффлайн monokl

  • Посетитель форума
  • Сообщений: 8
Большое спасибо!