☰

自动更新工作簿的链接

tag-icon • tag-icon microsoft-excel worksheet-function vba microsoft-excel-2007 vbscript
自动更新工作簿的链接

我正在寻找一种方法来逐个打开文件夹中的 .xlsb 文件，然后将其链接重命名或更新为 .xlsb。

例如，如果“C:\FINAL ANSWER\edit.xlsb”文件的链接为 ='C:\FINAL ANSWER\MAIN VALUES.xlsx!L30'，则代码

应该能够将该链接重命名为 ='C:\FINAL ANSWER\MAIN VALUES.xlsb!L30'。

每个文件夹都有许多工作簿，其中包含各种工作表，因此宏应该能够搜索每个工作簿和每个带有链接 .xlsx 的工作表，并将其替换为 .xlsb，如上所述。

谢谢

答案1

将以下内容复制到模块中并运行 UpdateLinks 宏。出现目录对话框以选择要执行链接更新的目录。检查即时窗口中的错误和统计信息。请发回一些输出并祝你好运！

手动执行此操作可能并不像人们想象的那么耗时。您不需要编辑每个单元格，甚至不需要编辑“命名范围”列表。每个属于一个或多个外部引用的唯一文件都是链接管理器中的单个条目。数据 [选项卡] | 查询和连接 [部分] | 编辑链接 [对话框] | 更改源... [对话框] 允许您修改每个引用的文件。因此，即使一个文件在多个单元格和工作表中被引用，并且每个引用都指向引用文件中的不同工作表和范围，一次更改也会将所有引用更新为新文件名或位置（包括文件扩展名修改）。

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

相关内容