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”库的引用。

列出Excel中的超链接

1 个答案: