How to optimize a VBA Macro that adds a link to multiple Arabic words at once

问题

Building upon the response I receive to my previous question here, I want to create a macro to add one link to multiple Arabic words.

Example: if I have a text that has: horse or horses or pony, I need to link it to horses.com.

I was able to modify the original macro to add links to all of the three words successfully, but I believe that my code is bloated with repetition.

My question is: is there a way to condence the code with better expressions?

Here is my working code so far:

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

Thanks a lot.

回答1:

I have put some code below which will take a list of coded words and hyperlink each word throughout a document or the selected range. I think I've understood what you are trying to achieve but obviously I can't test my code because I don't use Arabic. However it does compile and has been code inspected by Rubberduck.

You may need to edit the string for 'http_address'.

You can extend the words you are looking for by adding them to the 'my_coded_words' array.

The const declaration will need to me moved to the top of the module (the declarations section) in which you put the code.

If there is anything you don't understand please ask, or, try pulling up the MS help page by putting the cursor on a keyword and pressing 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

来源：https://stackoverflow.com/questions/53541729/how-to-optimize-a-vba-macro-that-adds-a-link-to-multiple-arabic-words-at-once