автоматическое обновление ссылок на рабочие книги

Question

Я ищу способ открыть файлы .xlsb в папке один за другим, а затем переименовать или обновить свои ссылки как .xlsb.

Например, если файл «C:\FINAL ANSWER\edit.xlsb» содержит ссылки в виде = 'C:\FINAL ANSWER\MAIN VALUES.xlsx!L30 'тогда код

должна иметь возможность переименовать эту ссылку как = 'C:\FINAL ANSWER\MAIN VALUES.xlsb!L30.

В каждой папке много книг с различными листами, поэтому макрос должен иметь возможность искать в каждой книге и на всех листах ссылки .xlsx и заменять их на .xlsb, как описано выше.

Спасибо

Answer 1

Скопируйте следующее в модуль и запустите макрос UpdateLinks. Появится диалоговое окно каталога, в котором можно выбрать каталог для обновления ссылок. Проверьте ваше немедленное окно на наличие ошибок и статистики. Пожалуйста, опубликуйте некоторые результаты и удачи!

Это может быть не так много времени, чтобы сделать вручную, как можно подумать. Вам не нужно редактировать каждую ячейку или даже список именованных диапазонов. Каждый уникальный файл, являющийся частью одной или нескольких внешних ссылок, является отдельной записью в менеджере ссылок. Данные [Tab] | Запросы и соединения [Раздел] | Редактировать ссылки [Диалог] | Изменить источник ... [Диалог] позволяет вам изменять каждый файл, на который есть ссылка. Таким образом, даже если на файл ссылаются несколько ячеек и листов, и каждая из ссылок относится к разному листу и диапазону в указанном файле, одно изменение обновляет все ссылки на новое имя или местоположение файла (включая модификацию расширения файла).

Option Explicit
Private Const OpenFiles = "xlsb|xls|xlt|xlsx|xltx|xlsm|xltm" 'single ext is OK
Private Const OldExt = "xlsx"
Private Const NewExt = "xlsb"
Sub UpdateLinks()
    Dim directory, excelFiles() As String
    Dim wb As Workbook
    Dim app As Excel.Application
    Dim totalUpdates As Integer

    directory = getDirectory
    excelFiles = getExcelFiles(directory)
    If LBound(excelFiles) = 0 Then 'empty excel file list for directory
        MsgBox "Directory '" & directory & "' has no files of type *." _
            & Join(Split(OpenFiles, "|"), ", *.")
        End 'Exit Subroutine and Execution Call Stack
    End If '(Else)
    Debug.Print "DIRECTORY '" & directory & "' has " _
        & UBound(excelFiles) & " excel file(s)."
    Set app = New Excel.Application
    app.DisplayAlerts = False
    app.AutomationSecurity = msoAutomationSecurityForceDisable 'disable macros

    totalUpdates = 0
    Dim file As Variant
    For Each file In excelFiles
        Set wb = openWorkbook(app, directory & Application.PathSeparator & file)
        If Not wb Is Nothing Then
            totalUpdates = totalUpdates + updateExcelLinks(wb)
            wb.Close
        End If
    Next file
    app.Quit
    Debug.Print "COMPLETE: " & totalUpdates & " link(s) updated from '" _
        & OldExt & "' to '" & NewExt & "'."
End Sub
Function updateExcelLinks(ByRef wb As Workbook) As Integer
    updateExcelLinks = 0
    Dim links As Variant
    links = wb.LinkSources(xlExcelLinks) 'includes externally Named Ranges
    If IsEmpty(links) Then
        Debug.Print "No Excel links in '" & wb.Name & "'."
        Exit Function
    End If '(Else) Process Links
    Dim l As Variant
    For Each l In links
        If StrComp(OldExt, Right(l, Len(l) - InStrRev(l, "."))) = 0 Then
            wb.ChangeLink l, Left(l, InStrRev(l, ".")) & NewExt
            updateExcelLinks = updateExcelLinks + 1
        End If
    Next l 'xlExcelLinks iterator
    If updateExcelLinks = 0 Then
        Debug.Print "No links with '" & OldExt & "' extensions in '" & wb.Name & "'."
    ElseIf wb.ReadOnly Then
        Debug.Print "ERROR, cannot save '" & wb.Name & "' (opened in another app). " _
            & updateExcelLinks & " link extension(s) NOT updated."
        updateExcelLinks = 0
        wb.Saved = True 'discard unsavable workbook changes
    Else
        wb.Save
        Debug.Print "Updated " & updateExcelLinks & " excel link extension(s) in '" & wb.Name & "'."
    End If
End Function
Function openWorkbook(ByRef app As Excel.Application, ByVal fileName As String) As Workbook
    Err.Clear
    On Error Resume Next
    Set openWorkbook = app.Workbooks.Open(fileName, 0) '0 is do not update ext refs when opening
    If Not openWorkbook Is Nothing And openWorkbook.FileFormat <> xlCurrentPlatformText Then
        Exit Function 'Return valid workbook
    End If '(Else)
    'Not a valid Workbook
    If Err.Number <> 0 Then
        Debug.Print "ERROR: Could not open excel workbook '" & fileName & "'. " _
            & vbCrLf & "Error #" & Err.Number & " - " & Err.Description
        Err.Clear
    Else
        Debug.Print "ERROR: Not a valid excel workbook '" & fileName _
             & "' (opened as a text file)."
    End If
    If Not openWorkbook Is Nothing Then
        openWorkbook.Close (False) 'False is don't save
        Set openWorkbook = Nothing
    End If
End Function
Function getExcelFiles(ByVal directory As String) As String()
    Dim f As String
    Dim fnames() As String
    ReDim fnames(0) 'testing has shown this is neither inefficient nor slow

    f = Dir(directory & Application.PathSeparator)
    Do While Len(f) > 0
        If InStr("|" & OpenFiles & "|", "|" & Right(f, Len(f) - InStrRev(f, ".")) & "|") Then
            If LBound(fnames) = 0 Then
                ReDim fnames(1 To 1)
            Else
                ReDim Preserve fnames(1 To UBound(fnames) + 1) 'see redim fname comment above
            End If
            fnames(UBound(fnames)) = f
        End If
        f = Dir 'get next iterative file from the original Dir called with argument
    Loop
    getExcelFiles = fnames
End Function
Function getDirectory() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = " Link Updater - Select Director"
        .ButtonName = "Select"
        .InitialFileName = CurDir ' OR ActiveWorkbook.Path OR Set a Const at top of file
        If .Show = -1 Then
            getDirectory = .SelectedItems(1)
        Else
            End 'Exit Subroutine and Execution Call Stack
        End If
    End With
End Function