Проверьте и исправьте неработающие ссылки в excel на другие листы

Faiz Shaikh спросил: 12 мая 2018 в 03:52 в: excel

Здравствуйте, я новичок в VBA и на этом форуме.

Итак, у меня есть книга, в которой хранятся данные из других книг с использованием активных ссылок (поэтому я могу обновить рабочий лист и получить обновленные значения) и гиперссылка (для скопированной книги), вставленная в один из столбцов. Я хочу проверить, не сломаны ли ссылки и не исправлять их. Поэтому я добавил кнопку обновления, чтобы обновлять значения и ErrorHandler, но я не уверен, как получить excel, чтобы определить / сохранить, какая строка имеет неработающую ссылку, и вставить новую ссылку в файл. Возможно ли это, и как бы я это сделал.

Если это невозможно, можно ли идентифицировать сломанные гиперссылки (столбец с вложенными гиперссылками). Я нашел этот форум, но не знаю, как его изменить, чтобы он проверял файлы excel? Проверка поврежденных гиперссылок в 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.LinkSourcesHRepair:
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

excel vba excel-vba

2 ответа

Sammy ответил: 12 мая 2018 в 06:42

Посмотрите, поможет ли вам следующее:

Проверьте, существует ли URL-адрес

Fix Hyperlinks

Faiz Shaikh ответил: 13 мая 2018 в 08:17

Итак, я нашел этот код онлайн и изменил его для своих целей. Вы можете получить его, чтобы проверить все различные случаи, которые вы хотите для ссылок. Я добавлю приглашение повторно связать файл, если он сломан.

Надеюсь, это поможет всем!

Sub GetLinkStatus () Dim avLinks Как VariantDim nIndex As IntegerDim sResult As StringDim nStatus As IntegerDim sLink Как строка

    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