☰

获取 Excel 2003 文档的所有链接文件

tag-icon • tag-icon microsoft-excel vba microsoft-excel-2003
获取 Excel 2003 文档的所有链接文件

我想获取 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

相关内容