活动工作簿更改链接

Posted 2023-04-19

【中文标题】活动工作簿更改链接

【英文标题】：Activeworkbook changelink

【发布时间】：2017-04-10 10:15:10

【问题描述】：

我想像这样使用 activeworkbook.changelink：

ActiveWorkbook.ChangeLink 

Name:= *current workbook*
NewName:= *Open the folder of current workbook from where I can choose the new file*

如果我在单元格中有一个链接（“c:\Docs\example.xls”），但我想将其更改为某些内容（我在 c:\Docs 中有更多文件，例如“example2.xls”，“ example3.xls",...) 宏应该会打开 c:\Docs\ 文件夹（浏览对话框），我可以从中选择要使用的文件。

你能给我一些建议吗？非常感谢！

【问题讨论】：

您能否更详细地解释您遇到的问题以及您正在尝试做的事情？如果你能举个例子说明你希望发生的事情，展示之前和之后，那会很有帮助。

当然。如果我在单元格中有一个链接（“c:\Docs\example.xls”），但我想将其更改为某些内容（我在 c:\Docs 中有更多文件，例如“example2.xls”、“example3.xls ",...) 宏应该打开 c:\Docs\ 的文件夹，我可以从中选择我想要使用的文件。

那么您想知道如何打开“浏览”对话框吗？

是的。抱歉，我的 excel 不是英文的，我不知道它的正确名称。

没关系，我只是想确定您遇到了什么问题:)。您能否编辑问题以添加此信息？

【参考方案1】：

终于有时间完成这个了。它的工作，所以我分享它。也许它对某人有用:)

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