Как оптимизировать макрос VBA, который добавляет ссылку на несколько арабских слов одновременно

Question

Основываясь на ответе Я получаю мой предыдущий вопрос здесь , я хочу создать макрос для добавления одной ссылки на несколько арабских слов.

Пример:если у меня есть текст, который имеет: horse или horses или pony, мне нужно связать его с horses.com.

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

Мой вопрос: есть ли способ соотнести код с лучшими выражениями?

Вот мой рабочий код такдалеко:

Sub FindAndHyperlink3()
    'set the search range
    Dim rngSearch1 As Range, rngSearch2 As Range, rngSearch3 As Range
    Set rngSearch1 = ActiveDocument.Range
    Set rngSearch2 = ActiveDocument.Range
    Set rngSearch3 = ActiveDocument.Range
    'set the search string 3 words
    'set the target address for the hyperlink
    Dim strAddress As String
    strAddress = "http:\\google.com"
    Dim strSearch1 As String, strSearch2 As String, strSearch3 As String, Word1 As String, Word2 As String, Word3 As String

Dim valWord1 As Variant
Dim valWord2 As Variant
Dim valWord3 As Variant
Dim i As Long, j As Long, k As Long
Word1 = "01575,01604,01571,01606,01576,01575,00032,01594,01585,01610,01594,01608,01585,01610,01608,01587"
Word2 = "01603,01610,01585,01604,01587,00032,01575,01604,01585,01575,01576,01593"
Word3 = "01575,01604,01575,01603,01604,01610,01585,01603,01610,01577"
valWord1 = Split(Word1, ",")
valWord2 = Split(Word2, ",")
valWord3 = Split(Word3, ",")

For i = LBound(valWord1) To UBound(valWord1)
    strSearch1 = strSearch1 & ChrW(valWord1(i))
Next
    With rngSearch1.Find
        Do While .Execute(findText:=strSearch1, MatchWholeWord:=True)
            With rngSearch 'we will work with what is found as it will be the selection
                ActiveDocument.Hyperlinks.Add Anchor:=rngSearch1, Address:=strAddress, Target:=blank
            End With
            rngSearch1.Collapse Direction:=wdCollapseEnd
            'keep it moving
        Loop
    End With

For j = LBound(valWord2) To UBound(valWord2)
    strSearch2 = strSearch2 & ChrW(valWord2(j))
Next
    With rngSearch2.Find
        Do While .Execute(findText:=strSearch2, MatchWholeWord:=True)
            With rngSearch2 'we will work with what is found as it will be the selection
                ActiveDocument.Hyperlinks.Add Anchor:=rngSearch2, Address:=strAddress, Target:=blank
            End With
            rngSearch2.Collapse Direction:=wdCollapseEnd
            'keep it moving
        Loop
    End With

For k = LBound(valWord3) To UBound(valWord3)
    strSearch3 = strSearch3 & ChrW(valWord3(k))
Next
    With rngSearch3.Find
        Do While .Execute(findText:=strSearch3, MatchWholeWord:=True)
            With rngSearch3 'we will work with what is found as it will be the selection
                ActiveDocument.Hyperlinks.Add Anchor:=rngSearch3, Address:=strAddress, Target:=blank
            End With
            rngSearch3.Collapse Direction:=wdCollapseEnd
            'keep it moving
        Loop
    End With

End Sub

Большое спасибо.

Answer 1

Я поместил код ниже, который будет принимать список закодированных слов и гиперссылку на каждое слово в документе или выбранном диапазоне.Я думаю, что понял, чего вы пытаетесь достичь, но, очевидно, я не могу проверить свой код, потому что я не использую арабский язык.Однако он компилируется и проверяется кодом в Rubberduck.

Вам может потребоваться изменить строку для 'http_address'.

Вы можете расширить слова, которые вы ищете, добавив их вМассив 'my_coded_words'.

Мне потребуется перенести объявление const в верхнюю часть модуля (раздел объявлений), в который вы помещаете код.

Если есть что-то, чего вы не делаете 'Пожалуйста, спросите, или попробуйте открыть страницу справки MS, наведя курсор на ключевое слово и нажав F1.

Option Explicit

Public Const http_address                       As String = "http:\google.com"

Sub test()

Dim coded_words                                 As Variant

    coded_words = _
        Array( _
            "01575,01604,01571,01606,01576,01575,00032,01594,01585,01610,01594,01608,01585,01610,01608,01587", _
            "01603,01610,01585,01604,01587,00032,01575,01604,01585,01575,01576,01593", _
            "01575,01604,01575,01603,01604,01610,01585,01603,01610,01577")

    'search whole document
    FindAndHyperlink coded_words

    ' or search just within the selected range
    FindAndHyperlink coded_words, Selection.Range
End Sub

Sub FindAndHyperlink(ByRef this_word_array As Variant, Optional ByRef this_range As Word.Range)

Dim search_rng                                   As Word.Range
Dim arabic_word                                  As String
Dim coded_word                                   As Variant

    If this_range Is Nothing Then

        Set search_rng = ActiveDocument.Content

    Else

        Set search_rng = this_range.Duplicate

    End If

    For Each coded_word In this_word_array

        arabic_word = AssembleArabicWord(CStr(coded_word))

        With search_rng

            With .Find

                .ClearFormatting
                .Text = arabic_word
                .MatchWholeWord = True
                .Wrap = wdFindStop
                ' Put any other search options here
                .Execute

            End With

            Do While .Find.Found

               .Duplicate.Hyperlinks.Add Anchor:=.Duplicate, Address:=http_address
               .Collapse Direction:=wdCollapseEnd
               .Move unit:=wdCharacter, Count:=1
               .Find.Execute

            Loop

        End With

    Next

End Sub

Function AssembleArabicWord(ByVal this_string As String) As String

Dim characters                               As Variant
Dim character                                As Variant
Dim result                                   As String

    characters = Split(this_string, ",")

    For Each character In characters

        result = result & ChrW$(character)

    Next

    AssembleArabicWord = result

End Function