Activeworkbook changelink - excel

Question

I would like to use activeworkbook.changelink like this:
ActiveWorkbook.ChangeLink
Name:= *current workbook*
NewName:= *Open the folder of current workbook from where I can choose the new file*
If I have a link in a cell ("c:\Docs\example.xls") but I want to change it to something (I have more files in c:\Docs, like "example2.xls", "example3.xls",...) the macro should open the folder of c:\Docs\ (Browse dialog) from where I could chose the file I want to use.
Can you suggest me something? Many thanks!

Answer 1

Finally I got time to finish this one. It's working so I share it. Maybe it will be useful for somebody :)
Sub Linkchange()
Const RefText = "#REF"
Dim fd As Office.FileDialog
Dim txtFileName, Msg As String
Dim OldLink_num As Long
Dim ws As Worksheet
Dim FindRef As Range
Dim SheetLoop
Dim FirstAddress
Dim UserOption
alink = ThisWorkbook.LinkSources
If IsEmpty(alink) Then
Msgbox "Nothing is attached."
Else
For Idx = 1 To UBound(alink)
Msg = Msg & (Idx) & ". " & alink(Idx) & vbCrLf & vbNewLine
Next
Msgbox Msg
Linkchange_userform.Show
'Private Sub CommandButton1_Click()
'Dim a As Long
'a = ListBox1.Value
'Msgbox a & ". is chosen"
'Unload Me
'End Sub
'Private Sub ListBox1_Click()
'End Sub
'Private Sub UserForm_Initialize()
'Dim Idx As Long
'alink = ActiveWorkbook.LinkSources
'For Idx = 1 To UBound(alink)
' ListBox1.AddItem Idx
'Next
'ListBox1.ListIndex = 0
'End Sub
OldLink_num = Linkchange_userform.ListBox1.Value
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Pick a file!"
.InitialFileName = Left$(alink(OldLink_num), InStrRev(alink(OldLink_num), "\"))
.Filters.Clear
.Filters.Add "All Files", "*.*"
If .Show = True Then
txtFileName = .SelectedItems(1)
Else
Exit Sub
End If
End With
ActiveWorkbook.ChangeLink Name:=alink(OldLink_num), NewName:=txtFileName, Type:=xlLinkTypeExcelLinks
Msgbox "Ready!"
Application.ScreenUpdating = False
For SheetLoop = 1 To ThisWorkbook.Sheets.Count
Set FindRef = ThisWorkbook.Sheets(SheetLoop).Cells.Find(RefText, lookat:=xlPart, LookIn:=xlValues)
If Not FindRef Is Nothing Then
FirstAddress = FindRef.Address
While Not FindRef Is Nothing
UserOption = Msgbox("Fail at - " & ThisWorkbook.Sheets(SheetLoop).Name & ", cell " & FindRef.Address & vbNewLine & "To continue: OK" & vbNewLine & "To exit: Cancel", vbOKCancel)
If UserOption = vbCancel Then
Exit Sub
End If
Set FindRef = ThisWorkbook.Sheets(SheetLoop).Cells.FindNext(FindRef)
If FindRef.Address = FirstAddress Then
Set FindRef = Nothing
End If
Wend
End If
Next SheetLoop
Application.ScreenUpdating = True
End If
End Sub