Список гиперссылок в Excel

Question

Я прочитал рабочую книгу Excel, содержащую большое количество листов. Каждый лист имеет от 1 до 12 гиперссылок к различным документам на веб-сайте. Эти рекомендации время от времени обновляются. Мне нужен макрос, в котором перечислены все гиперссылки на новом листе, но также будет указано имя листа рядом с каждой ссылкой. У меня есть следующий, выводящие гиперссылка и сотовый реф

Sub CopyHyperLinks() 
    Dim rCell As Range 
    Dim ws As Worksheet 
    Dim Lhyper As Long     
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Sheets("Hypers").Delete 
    On Error Goto 0 
    Application.DisplayAlerts = True 
    Sheets.Add().Name = "Hypers" 

    For Each ws In Worksheets 
    If ws.Name <> "Hypers" Then 
     For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count 
     ws.Hyperlinks(Lhyper).Range.Copy 
     With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up) 
      .Offset(1, 0).PasteSpecial 
      .Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address 
     End 
     Application.CutCopyMode = False 
     Next Lhyper 
    End If 
    Next ws 
End Sub 

Как я могу изменить это, чтобы показать имя листа вместо клеток реф. Можно ли также проверить, являются ли эти гиперссылки действительными местами назначения?

Answer 1

Вы можете получить имя рабочего листа гиперссылке с этой линией:

ws.Hyperlinks(Lhyper)..Range.Worksheet.Name 

Вот твой переработан код (он содержал некоторые другие синтаксические ошибки, которые я исправил):

Sub CopyHyperLinks() 
    Dim rCell As Range 
    Dim ws As Worksheet 
    Dim Lhyper As Long 
    Dim rngLink As Range 

    Application.DisplayAlerts = False 

    On Error Resume Next 
    Sheets("Hypers").Delete 

    On Error GoTo 0 
    Application.DisplayAlerts = True 

    Sheets.Add().Name = "Hypers" 

    For Each ws In Worksheets 
     If ws.Name <> "Hypers" Then 
      For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count 
       Set rngLink = ws.Hyperlinks(Lhyper).Range 
       rngLink.Copy 
       With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp) 
        .Offset(1, 0).PasteSpecial 
        .Offset(1, 1) = rngLink.Address 
        .Offset(1, 2) = rngLink.Worksheet.Name 
        .Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address) 
       End With 
       Application.CutCopyMode = False 
      Next Lhyper 
     End If 
    Next ws 
End Sub 

Если вы хотите проверить ссылки, укажите код from this answer. Включите эту строку в коде:

.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address) 

, а также эта процедура:

Public Function CheckHyperlink(ByVal strUrl As String) As Boolean 

    Dim oHttp As New MSXML2.XMLHTTP30 

    On Error GoTo ErrorHandler 
    oHttp.Open "HEAD", strUrl, False 
    oHttp.send 

    If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True 

    Exit Function 

ErrorHandler: 
    CheckHyperlink = False 
End Function 

Вам необходимо включить ссылку на библиотеку «Microsoft XML» в проекте VBA.