Find and Replace with Hyperlink Doc from Excel - 438 Error

[sferrier]

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

[gmaxey]

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

[sferrier]

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

[gmaxey]

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.

[sferrier]

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.

[gmaxey]

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