![获取 Excel 2003 文档的所有链接文件](https://linux22.com/image/1305166/%E8%8E%B7%E5%8F%96%20Excel%202003%20%E6%96%87%E6%A1%A3%E7%9A%84%E6%89%80%E6%9C%89%E9%93%BE%E6%8E%A5%E6%96%87%E4%BB%B6.png)
我想获取 Excel 2003 文档中所有链接文件的列表,或者更好的是,自动检索链接到该文档的所有文件并压缩它们。这样的操作可行吗?我发现手动收集文件非常繁琐。
答案1
更简单的方法是使用.LinkSources
方法。
例如,下面的代码将打印所有 Excel 文件的链接列表。
Sub PrintLinks()
Dim v() As Variant, i As Integer
v = ThisWorkbook.LinkSources(XlLink.xlExcelLinks)
For i = 1 To UBound(v)
Debug.Print v(i)
Next i
End Sub
答案2
这是一个开始。此宏将通过在工作簿中的所有公式中查找文件名来返回所有链接工作簿的列表。需要注意的一个怪癖是,如果工作簿当前未打开,它将仅返回工作簿的文件路径。我还没有花时间想出解决这个问题的方法,但好消息是,如果工作簿已经打开,您应该知道文件路径。
Sub getlinks()
Dim ws As Worksheet
Dim tmpR As Range, cellR As Range
Dim links() As String
Dim i As Integer, j As Integer
j = 0
'Look through all formulas for workbook references. Store all refs in an array.
For Each ws In ThisWorkbook.Worksheets
Set tmpR = ws.UsedRange
For Each cellR In tmpR.Cells
i = InStr(cellR.Formula, "'")
If i <> 0 Then
ReDim Preserve links(0 To j) As String
links(j) = Mid(cellR.Formula, i, InStr(i + 1, cellR.Formula, "'") - i)
j = j + 1
Do While i <> 0
On Error GoTo ErrHand
i = InStr(i + 1, cellR.Formula, "'")
i = InStr(i + 1, cellR.Formula, "'")
If i <> 0 Then
ReDim Preserve links(0 To j) As String
links(j) = Mid(cellR.Formula, i, InStr(i + 1, cellR.Formula, "'") - i)
j = j + 1
End If
Loop
End If
Next cellR
Next ws
'Add new worksheet to post list of links.
Set ws = Sheets.Add
ws.Name = "List of Linked Workbooks"
Set tmpR = ws.Range("A1").Resize(UBound(links) + 1, 1)
tmpR = Application.WorksheetFunction.Transpose(links)
'Clean up output.
For Each cellR In tmpR
cellR = Left(cellR.Value, InStr(cellR.Value, "]") - 1)
cellR = Replace(cellR.Value, "[", "")
Next cellR
'Code to remove duplicates from list. .RemoveDuplicates property only works for Excel 2007 and later. Line is commented out below.
'tmpR.RemoveDuplicates Columns:=1, Header:=xlNo
Exit Sub
ErrHand:
i = 0
Resume Next
End Sub