Consulting

Results 1 to 6 of 6

Thread: Find and Replace with Hyperlink Doc from Excel - 438 Error

  1. #1

    Find and Replace with Hyperlink Doc from Excel - 438 Error

    I cobbled together the below. I am trying to iterate through an excel columns. I want to find the string in column A in a Word document and insert a hyperlink based on a string in column B. This keeps giving me a 438 Error "object doesn't support this property or method" error. Any help or suggestions are greatly appreciated

    Sub Replace()
    
    
    Dim pathh As String
    Dim pathhi As String
    Dim oCell  As Integer
    Dim from_text As String, to_text As String
    Dim WA As Object
    Dim myRange As Object
    
    
    pathh = "C:\Users\sferr\Desktop\Replace Test\Test.docx"
    
    
    Set WA = CreateObject("Word.Application")
    WA.Documents.Open (pathh)
    WA.Visible = True
    
    
    For oCell = 1 To 100
        from_text = Sheets("Sheet1").Range("A" & oCell).Value
        to_text = Sheets("Sheet1").Range("B" & oCell).Value
    Next oCell
        With WA.ActiveDocument
            Do While .Execute(FindText:=from_text, MatchWholeWord:=True, Forward:=True) = True
            Set myRange = .Content
            With myRange.Find
            .Execute FindText:=from_text
            .Hyperlinks.Add Anchor:=myRange, Address:=to_text
            End With
            myRange.Collapse Direction:=wdCollapseEnd
            Loop
        End With
    End Sub

  2. #2
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Sub Replace()
    Dim lngCell  As Long
    Dim oAppWord As Object, oDoc As Object, oRng As Object
    Dim bKillWord As Boolean
      
      On Error Resume Next
      bKillWord = False
      Set oAppWord = GetObject(, "Word Application")
      If Err.Number <> 0 Then
        Set oAppWord = CreateObject("Word.Application")
        bKillWord = True
      End If
      Set oDoc = oAppWord.Documents.Open("D:\Test0316.docm")
      For lngCell = 1 To 100
        On Error GoTo Err_Handler
        Set oRng = oDoc.Range
        With oRng.Find
          .Text = Sheets("Sheet1").Range("A" & lngCell).Value
          .MatchWholeWord = True
          While .Execute
            oRng.Hyperlinks.Add oRng, Sheets("Sheet1").Range("B" & lngCell).Value
            oRng.Collapse 0
          Wend
        End With
      Next lngCell
    lbl_Exit:
      oDoc.Close -1
      If bKillWord Then oAppWord.Quit
      Set oDoc = Nothing: Set oAppWord = Nothing
      Exit Sub
    Err_Handler:
      Resume lbl_Exit
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

  3. #3
    Thank you! This works but it does not fully format the text outside of the 1 digits. For example, in the word doc Test 1 looks like Test 1 and Test 10 looks like Test 10. The hyperlinks all go to the correct addresses though. I wrote the below to change the link formatting. I was wondering if there is a better way to do this.

    Private Sub Document_()
    Dim i As Integer
    On Error Resume Next
    
    For i = 1 To 100
        With ActiveDocument.Content.Find
            .Text = "Test Exhibit" + CStr(i)
        With .Replacement
            .Text = "Test Exhibit" + CStr(i)
            .Font.Underline = True
            .Font.ColorIndex = RGB(0, 0, 255)
        End With
        .Execute FindText:="", ReplaceWith:="", _
        Format:=True, Replace:=wdReplaceAll
    End With
    Next
    End Sub
    Last edited by sferrier; 03-17-2019 at 08:25 PM.

  4. #4
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    Why don't you give an example of what you have in column A and B of your Excel file and what is contained in the document. Then show what the document looks like before and after running the code.
    Greg

    Visit my website: http://gregmaxey.com

  5. #5
    Below to is a table simulating my excel and my word doc is in the text below. I think the best way to get an exact match is to write a regular expression, the meta code for it is also below. I am new to this so I am not 100% sure if the regular expression route is the correct way to go. Thanks again for all the help.

    search_list = []
    i = 0  
    For  All the Cells in Column A:   'Range("A" & lngCell).Value
         search_list.append(all values in column A)
         re.search(^ search_list[i]$)
          i = i +1
    Test 1 C:\Users\sferrier\Desktop\Replace Test\Exhibit1.png
    Test 10 C:\Users\sferrier\Desktop\Replace Test\Exhibit 10.jpg
    Test 1 C:\Users\sferrier\Desktop\Replace Test\Exhibit 100.jpg

    Word Doc

    Test run, I hope this Macro finds exactly Test 1 and places a hyperlink to Test 1. It should not replace Test 10 or Test 100. I also hope that my color change does not change random number like 5, 12, 45, or 25 to blue underline.
    Last edited by sferrier; 03-18-2019 at 07:07 AM. Reason: Not finished

  6. #6
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,334
    Location
    The code I gave you originally is running as it should but it seems Word is unable to apply the correct hyperlink mask over and existing hyperlink.

    Will there always be a space or a paragraph mark after the text to find. Part of the problem is that Word is always finding "Test 1" in all three examples. MatchWholdWord doesn't work with multiple words. If you could modify the find expression to include some stop e.g., a space or paragraph mark that would help.

    This works with the example you gave:

    Sub Replace()
    Dim lngCell  As Long
    Dim oAppWord As Object, oDoc As Object, oRng As Object
    Dim bKillWord As Boolean
      
      On Error Resume Next
      bKillWord = False
      Set oAppWord = GetObject(, "Word Application")
      If Err.Number <> 0 Then
        Set oAppWord = CreateObject("Word.Application")
        bKillWord = True
      End If
      For lngCell = 1 To 100
        Set oDoc = oAppWord.Documents.Open("D:\Test0316.docm")
        On Error Resume Next
        Set oRng = oDoc.Range
        With oRng.Find
          .Text = Sheets("Sheet1").Range("A" & lngCell).Value
          .MatchWholeWord = True
          While .Execute
            oRng.Hyperlinks(1).Delete
            oRng.Hyperlinks.Add oRng, Sheets("Sheet1").Range("B" & lngCell).Value
            oRng.Collapse 0
          Wend
        End With
      Next lngCell
    lbl_Exit:
      oDoc.Close -1
      If bKillWord Then oAppWord.Quit
      Set oDoc = Nothing: Set oAppWord = Nothing
      Exit Sub
    Err_Handler:
      Resume lbl_Exit
    End Sub
    Greg

    Visit my website: http://gregmaxey.com

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •