Question

我想像这样使用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 \（浏览对话框）的文件夹，从那里我可以选择我想要使用的文件。

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

Answer 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

Activeworkbook changelink

1 个答案: