excel 提取所有相关的链接文件并另存到指定位置

kaka1295

各路大神，小弟最近有一个需求，一个excel 工作簿里面可能引用了N个其他工作簿的内容参与计算，假设这些工作簿都在本地，但分散在不同的文件夹里面。我想一次性将所有链接到的文件都另存到一个我指定的地址，我整理了下思路，但是具体怎么编程就不太清楚。

1. 创建一个文件夹，选择路径，输入文件夹名
2. 打开第一个链接到的文件，另存到指定路径，然后关闭此文件。
3. 循环到所有文件都另存完毕。

希望大神不吝赐教！感激涕零！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.1
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     p = ThisWorkbook.Path & ""
   
6.     p1 = p & "data base"
   
7.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
   
8.     r = Cells(Rows.Count, 2).End(3).Row
   
9.     arr = Range("a1:b" & r)
   
10.     For i = 2 To UBound(arr)
    
11.         s = CStr(arr(i, 1))
    
12.         Application.SheetsInNewWorkbook = 1
    
13.         Set wb = Workbooks.Add
    
14.         wb.Sheets(1).[a1] = arr(i, 2)
    
15.         wb.SaveAs p1 & s
    
16.         wb.Close 1
    
17.         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=p1 & s & ".xlsx"
    
18.     Next
    
19.     Application.ScreenUpdating = True
    
20.     MsgBox "OK！"
    
21. End Sub
    
22. 
    

复制代码

kaka1295

ykcbf1100 发表于 2024-3-1 14:40
附件供参考。。。

非常感谢，但是附件好像打开来有错误，方便分享下代码不？

ykcbf1100

kaka1295 发表于 2024-3-1 14:58
非常感谢，但是附件好像打开来有错误，方便分享下代码不？

我这里没有问题，代码在3楼，在审核。

limonet

关键字：Formula

limonet

Sub Limonet()
    Dim Rng As Range
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then Path$ = .SelectedItems(1) & "\" Else Exit Sub
    End With
    For Each Rng In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
        If InStr(1, Rng.Formula, "[") > 0 Then
           FileCopy Replace(Mid(Split(Rng.Formula, "]")(0), 3), "[", ""), Path & Split(Mid(Split(Rng.Formula, "]")(0), 3), "[")(1)
       End If
    Next
End Sub

kaka1295

limonet 发表于 2024-3-1 15:49
Sub Limonet()
    Dim Rng As Range
    With Application.FileDialog(msoFileDialogFolderPicker)

亲测可用，非常感谢。

能否再进一步，提取整个工作簿的链接文件呢？

kaka1295

Sub DownloadFile()
    Dim Rng As Range
        Dim i As Integer
        Dim c As Integer
         c = ActiveWorkbook.Worksheets.Count
         
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then Path$ = .SelectedItems(1) & "\" Else Exit Sub
    End With
   
   
   
    For i = 1 To c
   
      For Each Rng In ActiveWorkbook.Worksheets(i).UsedRange.SpecialCells(xlCellTypeFormulas)
        If InStr(1, Rng.Formula, "[") > 0 Then
           FileCopy Replace(Mid(Split(Rng.Formula, "]")(0), 3), "[", ""), Path & Split(Mid(Split(Rng.Formula, "]")(0), 3), "[")(1)
       End If
      Next
   
    Next
   
    MsgBox "文件下载完成"
   
End Sub


改了下，但似乎运行不了，请大侠赐教。