在 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

您需要在 VBA 项目中包含对“Microsoft XML”库的引用。