Changing links with vba it's not an easy task. When i needed a code for changing links in vba, i was surprised to see that there is no such thing on the web. So i developed my own method...
The solution i use now consists in creating a name with a Get.Cell formula to extract the full path and workbook name of the existing link, then using it in the code.
The formula for a defined name SourceName is:
=SUBSTITUTE(LEFT(SUBSTITUTE(GET.CELL(6;Source!$C6) ;"=";"");FIND("]";GET.CELL(6;Source!$C6);1)-2);"[";"")
Obviously, in Sheet Source, cell C6 there is a link to the source workbook. (it does not matter to which cell from source is cell C6 linked, this formula is extracting the source workbook path and name from this reference)
In the cell next to C6, in D6, enter the formula: =SourceName ; now you have in cell D6 the full path and name of the source workbook. (there is no way to change links several times in vba without indicating the OldLnk source workbook and the NewName; after changing links, the workbook indicated for NewName will become the OldLnk for the next change of links...This was the real chalenge, which i solved with the named formula with Excel 4 macro.
In my version, i used an Application.GetOpenFilename to extract the adress of the parent folder that contains the needed files and then identified the needed source in that folder after a partial name.
Here is the code for changing links, which must be adjusted for your needs: (you can notice that OldLnk is dinamically reffered to: OldLnk = Sheets("Source").Cells(6, 4).Text, which contains the formula =SourceName ; the code is written for 3 or 4 source workbooks, in your case 1 is enough)
Code:
Sub SchimbaLinkuri()
Dim OldLnk, NewLnk, Opis, FolderSursa As String
Opis = "Alege Client Sursa"
Application.ScreenUpdating = False
Dim FSO As Object, ChFisier As String
ChFisier = "\\VPConsult3\D\Session 3"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(ChFisier) = True Then
CreateObject("WScript.Shell").CurrentDirectory = ChFisier
ChDir ChFisier
Else
'MsgBox "You are not connected to network"
End If
NewLnk = Application.GetOpenFilename("Excel files,*.xl*", _
1, Opis, , False)
If TypeName(NewLnk) = "Boolean" Then Exit Sub
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim Fisier, i, j, k, l
FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
For Each Fisier In oFSO.GetFolder(FolderSursa).Files
If InStr(1, Fisier.Name, "text", vbTextCompare) > 0 Then i = Fisier.Name
Next
FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
For Each Fisier In oFSO.GetFolder(FolderSursa).Files
If InStr(1, Fisier.Name, "date p", vbTextCompare) > 0 Then j = Fisier.Name
Next
FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
For Each Fisier In oFSO.GetFolder(FolderSursa).Files
If InStr(1, Fisier.Name, "venit", vbTextCompare) > 0 Then k = Fisier.Name
Next
'FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
'For Each Fisier In oFSO.GetFolder(FolderSursa).Files
'If InStr(1, Fisier.Name, "opis", vbTextCompare) > 0 Then l = Fisier.Name
'Next
If Not i = Empty And Not j = Empty And Not k = Empty Then 'And Not l = Empty
'Wb = FolderSursa & "\" & i
OldLnk = Sheets("Source").Cells(6, 4).Text
ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=i, Type:=xlExcelLinks
'Workbooks.Open (Wb)
'Workbooks(i).Close SaveChanges:=False
OldLnk = Sheets("Source").Cells(7, 4).Text
ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=j, Type:=xlExcelLinks
OldLnk = Sheets("Source").Cells(8, 4).Text
ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=k, Type:=xlExcelLinks
'OldLnk = Sheets("Source").Cells(9, 4).Text
'ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=l, Type:=xlExcelLinks
Else
MsgBox "This folder does not contain all necessary files!"
End If
End Sub