Подсчитать количество замен

[Svetik]

Помогите написать макрос, где я точно могу узнать, сколько произошло замен.

Например, в макросе проводится замены всех дефисов на неразрывные и пробелов на обычные

во всем тексте:

Спойлер

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
            .Text = "(-)"
            .Replacement.Text = ChrW(30)
            .Wrap = wdFindContinue
            .MatchWildcards = True
        End With

        Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
            .Text = "([^0160]{1;})"
            .Replacement.Text = "^32"
            .Wrap = wdFindContinue
            .MatchWildcards = True
            .Format = False

        End With

        Selection.Find.Execute Replace:=wdReplaceAll

[свернуть]

или в выделении:

Спойлер

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "(-)"
            .Replacement.Text = ChrW(30)
            .Wrap = wdFindStop    'ищем в выделении
            .MatchWildcards = True
        End With

        Selection.Find.Execute Replace:=wdReplaceAll

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = "([^0160]{1;})"
            .Replacement.Text = "^32"
            .Wrap = wdFindStop    'ищем в выделении
            .MatchWildcards = True
        End With

        Selection.Find.Execute Replace:=wdReplaceAll

[свернуть]

Но вот только из-за специфики текста, мне очень точно нужно знать, сколько проведено замен. И дефисов, и тире. Причем замены идут одна за другой и привела я их не все, друг за другом таких замен у меня много.
Сколько не искала - не смогла найти готового решения.

[Администратор]

Вот такие коды, которые попробуйте адаптировать для себя, настроив параметры поиска и добавив в коды коды по замене. Встроенных инструментов у ворд нет для подсчёта кол-ва найденного или заменённого.

Коды сделаны на случай, когда замена происходит от начала в конец (в ворде можно вести ещё замену от конца в начало - для этого случая нужны другие коды).

Замена во всём файле

Sub Main()
   
    ' Замена и подсчёт во всём файле.
   
    Dim rng As Range, fnd As Find, lngCounter As Long
   
   
    '1. Поиск и подсчёт.

    '1) Создание объектов для поиска.
    Set rng = ActiveDocument.Range(0, 0)
    Set fnd = rng.Find
   
    '2) Настройка поиска. Настройте поиск так же, как вы это делаете в замене.
        ' Только не используйте параметры, относящиеся к "Replacement", т.к.
        ' в данном случае они не нужны.
    fnd.Text = "текст1"
    fnd.Wrap = wdFindStop
   
    '3) Поиск и подсчёт.
    Do
        If fnd.Execute = True Then
            ' Подсчёт найденных фрагментов.
            lngCounter = lngCounter + 1
            ' Смещение невидимого курсора вправо от найденго фрагмента.
            rng.Collapse Direction:=wdCollapseEnd
        Else
            Exit Do
        End If
    Loop
   
    '2. Здесь сделайте обычную замену, которую вы использовали всегда.
   
    '3. Сообщение.
    MsgBox "Замен: " & lngCounter

End Sub

[свернуть]

Замена в выделенном фрагменте

Sub Main()
   
    ' Замена в выделенном фрагменте.
        ' Подсчёт замен может оказаться меньше, чем было сделано замен на самом деле.
        ' Просто так нельзя выделить фрагмент, потому что в некоторых случаях поиск будет
        ' производиться не в выделенном фрагменте, а от начала выделенного фрагмента и до конца файла.
   
    Dim rng As Range, fnd As Find, lngSelEnd As Long, lngCounter As Long
   
   
    '1. Запись конца выделения, чтобы постоянно не обращаться к объекту "Selection".
    lngSelEnd = Selection.End
   

    '2. Поиск и подсчёт.
   
    '1) Создание объектов для поиска.
    Set rng = Selection.Range
    rng.Collapse Direction:=wdCollapseStart
    Set fnd = rng.Find
   
    '2) Настройка поиска. Настройте поиск так же, как вы это делаете в замене.
        ' Только не используйте параметры, относящиеся к "Replacement", т.к.
        ' в данном случае они не нужны.
    fnd.Text = "текст1"
    ' Чтобы поиск прекратился в конце файла и не начался заново.
    fnd.Wrap = wdFindStop
   
    '3) Поиск и подсчёт.
    Do
        If fnd.Execute = True Then
            ' Проверка, найдено ли в пределах выделенного.
            If rng.End > lngSelEnd Then
                Exit Do
            End If
            ' Подсчёт.
            lngCounter = lngCounter + 1
            ' Смещение невидимого курсора вправо.
            rng.Collapse Direction:=wdCollapseEnd
        Else
            Exit Do
        End If
    Loop
   
   
    '3. Здесь сделайте обычную замену, которую вы использовали всегда.
   
    '4. Сообщение.
    MsgBox "Замен: " & lngCounter

End Sub

[свернуть]

[Svetik]

А как правильно выделять фрагмент, чтобы поиск осуществлялся только в выделенном фрагменте, а не расширялся до конца файла?

[Администратор]

Правила выделения, наверное, нигде не написаны. Просто нужно выделять и смотреть, правильная происходит замена или нет.
Я отношу такое поведение программы "Word" к ошибке: я считаю, что поиск должен осуществляться строго в выделенном фрагменте.

[Администратор]

Вариант с использованием макроса и диалога "Найти и заменить".

В макросе, после команды:
VBA.SendKeys
ничего не должно быть, т.к. макрос не будет ждать окончания этой команды, а только покажет диалог и дальше продолжит выполнение.

Запускать макрос нужно только из ворд, а не из VBA, т.к. используется сочетание клавиш "Ctrl + H" и оно будет применено к VBA, а не к Word, если на мониторе отображается VBA.
Смысл такой: макрос задаёт настройки поиска и замены, затем отображает обычный диалог "Найти и заменить", вам надо щёлкнуть "Заменить все" и появится сообщение, сколько замен было сделано.

На макрос влияет язык клавиатуры. Если вы используете кроме русского и английского другие языки, то нужно изменить макрос.

Спойлер

Sub Main()

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "text1"
        .Replacement.Text = "text2"
    End With
    If Application.Keyboard = 67699721 Then
        VBA.SendKeys "^h"
    Else
        ' Русская "р".
        VBA.SendKeys "^р"
    End If
   
End Sub

[свернуть]

[Svetik]

Последний вариант для меня проблематичен, т.к. у меня замен друг за другом выполняется больше 20 и следуют сразу одна за другой.
Буду применять Ваши варианты, что предложили выше. Спасибо.