Я хочу получить список всех связанных файлов в документе Excel 2003 или, что еще лучше, автоматически извлечь все файлы, связанные с документом, и заархивировать их. Возможна ли такая операция? Я считаю сбор файлов вручную очень утомительным.
2 ответа
4
Более простой способ сделать это - использовать .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
1
Вот начало. Этот макрос вернет список всех связанных рабочих книг путем поиска имен файлов во всех формулах рабочей книги. Следует заметить, что он вернет путь к файлу книги, только если эта книга еще не открыта. Я не нашел время, чтобы найти способ обойти это, но хорошая новость заключается в том, что вы все равно должны знать путь к файлу, если рабочая книга уже открыта.
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