Well, i took the time to make another solution to your problem, with another approach, which is much faster than the previous , because it extracts the data from the target files without opening and closing those files. This version uses the list of workbooks in column A and a defined name with an Excel 4 macro formula (GET.CELL) to extract the file name from the existing link. Of course, this can be done completely in the code.
You might need to manually change the link from cell B3 to a real file in your computer, the code will not run with a broken link (actual link is to a file in my computer)
Code:
Option Explicit
Sub ChangeLinks()
Application.ScreenUpdating = False
Dim OldLnk, NewLnk, Target, i As String, j As Integer
NewLnk = Application.GetOpenFilename("Excel files,*.xl*", _
1, "Choose any file in the source folder", , False)
If TypeName(NewLnk) = "Boolean" Then Exit Sub
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim Fisier, FolderSursa As String, LastRow As Long
LastRow = ThisWorkbook.Sheets("1000000").Range("D" & Rows.Count).End(xlUp).Row
FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
For j = 3 To Sheets("1000000").Range("A" & Rows.Count).End(xlUp).Row
For Each Fisier In oFSO.GetFolder(FolderSursa).Files
Target = Sheets("1000000").Cells(j, "A")
If InStr(1, Fisier.Name, Target, vbTextCompare) > 0 Then
i = Fisier.Name
OldLnk = Sheets("1000000").Cells(3, "C").Text
ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=i, Type:=xlExcelLinks
Sheets("1000000").Cells(3, "B").Copy
Sheets("1000000").Cells(LastRow + 1, "D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
LastRow = LastRow + 1
End If
Next
Next j
Application.CutCopyMode = False
End Sub
If you do not want to use a defined name to extract tha path to source file, and you want the code to do all the work, you have to use this code:
Code:
Option Explicit
Sub ChangeLinks()
Application.ScreenUpdating = False
Dim OldLnk, NewLnk, Target, i As String, j As Integer
NewLnk = Application.GetOpenFilename("Excel files,*.xl*", _
1, "Choose any file in the source folder", , False)
If TypeName(NewLnk) = "Boolean" Then Exit Sub
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim Fisier, FolderSursa As String, LastRow As Long
With ThisWorkbook.Sheets("1000000")
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
FolderSursa = oFSO.GetFile(NewLnk).ParentFolder
For j = 3 To .Range("A" & Rows.Count).End(xlUp).Row
For Each Fisier In oFSO.GetFolder(FolderSursa).Files
Target = .Cells(j, "A")
If InStr(1, Fisier.Name, Target, vbTextCompare) > 0 Then
i = Fisier.Name
With Application ' extracting path with VB from existing link in cell B3 (without using defined name in worksheet)
OldLnk = .Substitute(.Cells(3, "B").Formula, "=", "")
OldLnk = Left(OldLnk, .Find("]", OldLnk) - 1)
OldLnk = .Substitute(OldLnk, "[", "")
End With
ActiveWorkbook.ChangeLink Name:=OldLnk, _
NewName:=i, Type:=xlExcelLinks
.Cells(3, "B").Copy
.Cells(LastRow + 1, "D").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
LastRow = LastRow + 1
End If
Next
Next j
Application.CutCopyMode = False
End With
End Sub