检查并修复 excel 中与其他工作表的断开链接

Question

您好，我是 VBA 和本论坛的新手。

所以我有一个工作簿，它使用活动链接从其他工作簿复制数据（因此我可以刷新工作表并获取更新的值）并将超链接（用于复制的工作簿）粘贴到其中一列中。我希望能够检查链接是否损坏并修复它们。所以我添加了一个刷新按钮来保持更新值和 ErrorHandler 到 sub 但我不确定如何让 excel 识别/存储哪一行有损坏的链接并将新链接粘贴到文件中。这可能吗，我该怎么做。

如果不可能，是否可以识别损坏的超链接（具有粘贴超链接的列）。我找到了这个论坛，但不确定如何更改它以便检查 excel 文件？ Checking for broken hyperlinks in Excel

     '///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'
'This code refreshes all links in the active worksheet.
'
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub RefreshAllLinks()

'Minimize runtime
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Initialize Variables
Dim summarywb As Workbook

'Set initial values
Set summarywb = ThisWorkbook

'Refresh all linked data on the active worksheet
summarywb.ActiveSheet.Activate
'On Error GoTo HRepair
summarywb.UpdateLink Name:=summarywb.LinkSources

HRepair:
Dim lngCount As Long
    Dim cl As Range

    Set cl = ActiveCell
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Show
        ' Display paths of each file selected
        For lngCount = 1 To .SelectedItems.Count
            ' Add Hyperlinks
            cl.Worksheet.Hyperlinks.Add _
                Anchor:=cl, Address:=.SelectedItems(lngCount), _
                TextToDisplay:=.SelectedItems(lngCount)
        Next lngCount
    End With

'Display back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

所以我在网上找到了这段代码，并出于我的目的对其进行了修改。您可以使用它来检查链接所需的所有不同情况。如果文件损坏，我会添加提示以重新链接文件。

希望对大家有帮助！

Sub GetLinkStatus()
    Dim avLinks As Variant
    Dim nIndex As Integer
    Dim sResult As String
    Dim nStatus As Integer
    Dim sLink As String

    avLinks = ActiveWorkbook.LinkSources(XlLink.xlExcelLinks)
    If IsEmpty(avLinks) Then
        GetLinkStatus1 = "No links in workbook."
        Exit Sub
    End If

    For nIndex = 1 To UBound(avLinks)
        sLink = avLinks(nIndex)
        sLink = Right(sLink, Len(sLink) - InStrRev(sLink, "\"))
        nStatus = ActiveWorkbook.LinkInfo(sLink, xlLinkInfoStatus)
        Select Case nStatus
                Case xlLinkStatusCopiedValues    ' Copied Values = 10
                    sResult = "Copied values"
                Case xlLinkStatusIndeterminate   ' Unable to determine status = 5
                    sResult = "Indeterminate"
                Case xlLinkStatusInvalidName     ' Invalid Name = 7
                    sResult = "Invalid name"
                Case xlLinkStatusMissingFile     ' File Missing = 1
                    sResult = "Missing file"
                Case xlLinkStatusMissingSheet    ' Sheet Missing = 2
                    sResult = "Missing sheet"
                Case xlLinkStatusNotStarted      ' Not Started = 6
                    sResult = "Not started"
                Case xlLinkStatusOK              ' No Errors = 0
                    sResult = "OK"
                Case xlLinkStatusOld            ' Status may be out of date = 3
                    sResult = "Old"
                Case xlLinkStatusSourceNotCalculated    ' Not yet calculated = 4
                    sResult = "Source not calculated"
                Case xlLinkStatusSourceNotOpen          ' Not open = 8
                    sResult = "Source not open"
                Case xlLinkStatusSourceOpen             ' Source document is open = 9
                    sResult = "Source open"
                Case Else
                    sResult = "Unknown status code"
            End Select
        If nStatus <> 0 And nStatus <> 3 Then ' Checking for Case No Errors and Status may be out of date
            ActiveSheet.Range("D1") = nStatus ' To check error
            MsgBox avLinks(nIndex) & " - the link is broken. Choose new destiation"
cf:
            f = Application.GetOpenFilename()
            If f <> "" Then
                ' Updating the "LINK"
                n = ActiveSheet.Cells(Rows.Count, 21).End(xlUp).Row
                For Each lnk In ActiveSheet.Range("U9:U" & n).Hyperlinks
                    GetAddress = lnk.Address
                    GetAddress = Right(GetAddress, Len(GetAddress) - InStrRev(GetAddress, "\"))
                    If InStr(avLinks(nIndex), GetAddress) <> 0 Then
                        ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(lnk.Range.Row, 21), Address:=f, TextToDisplay:="Link"
                    End If
                Next

                ActiveWorkbook.ChangeLink avLinks(nIndex), f, xlLinkTypeExcelLinks
            Else
                GoTo cf
            End If
        End If
    Next
End Sub

Answer 2

看看以下是否对你有帮助：

Check if URL exists

Fix Hyperlinks