Activeworkbook changelink

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