Change path in Linked Fields (for word links to excel)

I'm new to this site; do I need to buy points to get a response comment? I feel so close to a solution but it's just beyond my understanding.

Thank you macropod, I really appreciate your work.

That said, I turned off 'update automatic links at open' (file->options->advanced->general) and it didn't fix the problem. After I move the files, when I try to open the word doc, word freezes before opening and pops up with "Sorry, Excel can't open two workbooks with the same name at the same time." and then "Run-time error 083': Objects in this document contain links to files that cannot be found. The linked information will not be updated." and the debugger heads to VBA code line: ".SourceFullName = Replace(.SourceFullName, OldPath, NewPath)". I then need to use task manager to force end word and excel (excel is opened as background process).

But here's the strange thing ... If I open the newly moved excel sheet before I open then word doc I still get the "Sorry, Excel can't open two workbooks with the same name at the same time." but no run-time error. If push though all the error boxes and close and reopen the word doc, all the links have been updated correctly and it works.

I've created an excel file with 1 entry and a word doc with 1 link (and the macro) and still no luck.

Thanks a lot for any help.

I do not have any excel or word files open. When I attempt to open the freshly moved word doc, word clearly opens the old and new excel files in the background and struggles due to the file name. Long story short the previously linked macro does not work due to this error. I was able to find this macro which works well, if you are having an issue like this I'd reccomend this code.

Sub UpdateWordLinks()

Dim newFilePath As Variant
Dim excelDocs As Variant
Dim range As Word.range
Dim shape As shape
Dim section As Word.section

excelDocs = GetFileNamesbyExt(ThisDocument.Path, ".xlsx")

'The new file path as a string (the text to replace with)'
newFilePath = ThisDocument.Path & Application.PathSeparator & excelDocs(1)

Call updateFields(ThisDocument.fields, newFilePath)

For Each section In ThisDocument.Sections

Call updateHeaderFooterLinks(section.Headers, newFilePath)

Call updateHeaderFooterLinks(section.Footers, newFilePath)

Next

'Update the links
ThisDocument.fields.Update

Set newFilePath = Nothing
Set excelDocs(1) = Nothing
Set excelDocs = Nothing
Set range = Nothing
Set shape = Nothing
Set section = Nothing

End Sub

Function GetFileNamesbyExt(ByVal FolderPath As String, FileExt As String) As Variant

Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
ReDim Result(1 To MyFiles.Count)
i = 1
For Each MyFile In MyFiles
If InStr(1, MyFile.Name, FileExt) <> 0 Then
Result(i) = MyFile.Name
i = i + 1
End If
Next MyFile
ReDim Preserve Result(1 To i - 1)

GetFileNamesbyExt = Result

Set MyFile = Nothing
Set MyFSO = Nothing
Set MyFolder = Nothing
Set MyFiles = Nothing

End Function

Function updateHeaderFooterLinks(headersFooters As headersFooters, newFilePath As Variant)

Dim headerFooter As Word.headerFooter

For Each headerFooter In headersFooters

Call updateFields(headerFooter.range.fields, newFilePath)

Next

Set headerFooter = Nothing

End Function

Function updateFields(fields As fields, newFilePath As Variant)

Dim field As field
Dim oldFilePath As Variant

For Each field In fields

If field.Type = wdFieldLink Then

oldFilePath = field.LinkFormat.SourceFullName

field.Code.Text = Replace(field.Code.Text, _
Replace(oldFilePath, "\", "\\"), _
Replace(newFilePath, "\", "\\"))

End If

Next

Set field = Nothing
Set oldFilePath = Nothing

End Function