Word VBA Макросы: Найти и удалить гиперссылку в сносках.

[Kasia]

Проблема такая - нужно найти в сносках слово google и удалить у этих слов гиперссылку. Остальные слова с гиперссылками не менять.
Я записала макрос найти и заменить, но он только находит нужные мне слова. А как проверить, есть ли у этих слов гиперссылка и удалить ее?

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

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

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

В самом верху модуля вставьте 'Option Compare Text' (без кавычек), чтобы поиск вёлся без учёта регистра букв (больших / маленьких букв).

Поместите обе процедуры в один модуль. Запускайте процедуру 'Макрос'.

Макрос

Sub Макрос()
   
    ' Отключение монитора (может это ускорит макрос).
    Application.ScreenUpdating = False
   
    '1. Удаление гиперссылок в страничных сносках.
    If ActiveDocument.Footnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdFootnotesStory)
    End If
   
    '2. Удаление гиперссылок в концевых сносках.
    If ActiveDocument.Endnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdEndnotesStory)
    End If
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    '3. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub DelHyperlinks(rng As Range)
   
    Dim hyp As Hyperlink, i As Long
   
    ' Движение по всем гиперссылкам, которые есть в сносках, от последней к первой.
    For i = rng.Hyperlinks.Count To 1 Step -1
        ' Присваиваем гиперссылке имя 'hyp'. Далее в коде будем обращатья к гиперссылке по имени 'hyp',
            ' это должно упростить чтение и написание макроса.
        Set hyp = rng.Hyperlinks(i)
        ' Если в гиперссылке есть слово 'google'.
        If InStr(hyp.TextToDisplay, "google") <> 0 Then
            ' Удаление гиперссылки. Удаляется только гиперссылка, а текст остаётся.
            hyp.Delete
        End If
    Next i

End Sub

[свернуть]

[Kasia]

Большое спасибо! Попробую.
А можно вместо слова "google" использовать подстановочные знаки, например искать слово из английских букв <[A-z]@>?

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

Поиск с использованием 'Найти и заменить'.
В этом случае параметр 'Option Compare Text' не имеет значения.

Макрос

Sub Макрос()
   
    ' Отключение монитора (может это ускорит макрос).
    Application.ScreenUpdating = False
   
    '1. Удаление гиперссылок в страничных сносках.
    If ActiveDocument.Footnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdFootnotesStory)
    End If
   
    '2. Удаление гиперссылок в концевых сносках.
    If ActiveDocument.Endnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdEndnotesStory)
    End If
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    '3. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub DelHyperlinks(rng As Range)

    Dim find_rng As Range, find As find
    Dim i As Long
   
   
    '1. Создание объектов, которые будут искать.
    ' Присваиваем диапазону, в котором находятся сноски, имя find_rng.
    Set find_rng = rng.Duplicate
    ' Превращаем фрагмент в точку вставки. Действие аналогично этому:
        '1) юзер выделяет фрагмент;
        '2) затем юзер нажимает клавишу-стрелку влево.
        ' Если фрагмент будет в виде точки вставки, то поиск будет не в выделенном фрагменте, а
        ' по всей области, в данном случае по области сносок.
    find_rng.Collapse Direction:=wdCollapseStart
    ' Присваиваем имя 'find' объекту 'Find', который находится в объекте 'find_rng'.
        ' Сам не понимаю, что происходит здесь.
    Set find = find_rng.find
   
    '2. Настройка поиска.
    ' Что искать.
    find.Text = "<[A-z]@>"
    ' Постановочные символы.
    find.MatchWildcards = True
    ' Остановить поиск, когда будет достигнут конец области сносок.
    find.Wrap = wdFindStop
   
    '3. Поиск.
    Do While find.Execute = True
        ' Удаление гиперссылок. Несколько гиперссылок может быть, если найдено много текста, например, целый абзац.
        For i = find_rng.Hyperlinks.Count To 1 Step -1
            find_rng.Hyperlinks(i).Delete
        Next i
    Loop
   
End Sub

[свернуть]

[Kasia]

Большое спасибо Вам! У меня все заменилось!

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

Вариант как в ответе 1, но можно проверить, есть или нет в гиперссылке нужный текст, с помощью 'Найти и заменить'.
Может быть этот способ будет быстрее и оптимальнее, чем в ответе 3.
Option Explicit для данного макроса значения не имеет.

Макрос

Sub Макрос()
   
    ' Отключение монитора (может это ускорит макрос).
    Application.ScreenUpdating = False
   
    '1. Удаление гиперссылок в страничных сносках.
    If ActiveDocument.Footnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdFootnotesStory)
    End If
   
    '2. Удаление гиперссылок в концевых сносках.
    If ActiveDocument.Endnotes.Count <> 0 Then
        DelHyperlinks ActiveDocument.StoryRanges(wdEndnotesStory)
    End If
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
    '3. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Private Sub DelHyperlinks(rng As Range)
   
    Dim hyp As Hyperlink, i As Long
   
    ' Движение по всем гиперссылкам, которые есть в сносках, от последней к первой.
    For i = rng.Hyperlinks.Count To 1 Step -1
        ' Присваиваем гиперссылке имя 'hyp'. Далее в коде будем обращатья к гиперссылке по имени 'hyp',
            ' это должно упростить чтение и написание макроса.
        Set hyp = rng.Hyperlinks(i)
        ' Поиск в гиперссылке нужного текста.
        With hyp.Range.find
            ' Что искать.
            .Text = "<[A-z]@>"
            ' Подстановочные знаки.
            .MatchWildcards = True
            ' Не искать за пределами гиперссылки.
            .Wrap = wdFindStop
            ' Поиск.
            If .Execute = True Then
                ' Удаление гиперссылки. Удаляется только гиперссылка, а текст остаётся.
                hyp.Delete
            End If
        End With
    Next i

End Sub

[свернуть]