在Excel中列出超链接
我是一本包含大量工作表的Excel工作簿。 每张表有1到12个超链接，指向一个网站上的不同文档。 这些dicuments不时更新。 我想要一个macros，列出新工作表中的所有超链接，但也列出每个链接旁边的工作表名称。 我有以下列出超链接和单元格引用
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 我怎样才能修改这个显示表格名称，而不是单元格参考。 是否也可以检查这些超链接是否是有效的目的地？
你可以用这一行获得超链接工作表的名字：
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
如果你想validation链接，请包括来自这个答案的代码。 在你的代码中包含这一行：
.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”库的引用。