Dapatkan semua file yang ditautkan ke dokumen Excel 2003

Saya ingin mendapatkan daftar semua file yang ditautkan dalam dokumen Excel 2003, atau, lebih baik lagi, secara otomatis mengambil semua file yang ditautkan ke dokumen dan zipnya. Apakah operasi seperti itu mungkin? Saya menemukan mengumpulkan file secara manual sangat membosankan.

Cara yang lebih mudah untuk melakukannya adalah dengan menggunakan .LinkSourcesmetode ini.

Misalnya, kode di bawah ini akan mencetak daftar semua tautan ke file 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

Ini awal. Makro ini akan mengembalikan daftar semua buku kerja tertaut dengan mencari nama file di semua rumus di buku kerja. Satu kekhasan yang perlu diperhatikan adalah bahwa ia hanya akan mengembalikan jalur file buku kerja jika buku kerja itu saat ini tidak terbuka. Saya belum meluangkan waktu untuk mencari tahu tentang itu, tapi kabar baiknya adalah Anda harus mengetahui path file jika buku kerja sudah terbuka.

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